[VBA] tính tổng với nhiều điều kiện

[hungvinh1402]

Xin chào mọi người,
liên quan tới công việc cần tính tổng với nhiều điều kiện. do dữ liệu lớn 5k~10k dòng & cột nên không dùng công thức máy treo=> em nghĩ dùng VBA sẽ hiệu quả hơn
xin mọi người giúp đỡ giải bài toán dưới :
1. vùng cần chạy dữ liệu: sheet(Sum).range("T12:FFP571")
2. ở sheet(Sum):
- ở cột A hàng nào =1 thì bỏ qua
- nếu cột A khác 1 và cột F (cùng hàng) không trống thì :với điều kiện cột màu xanh và hàng màu đỏ tương ứng với sheet(data) thì tính tổng:
+ Nếu ở hàng số 11: cột nào = 1 tính tổng sheet(data) cột số dư
+ : cột nào =2 tính tổng sheet(data) cột số lượng trả lại
còn lại là bỏ qua
xin cảm ơn
P/S: em có code mà máy nó treo. có lẽ chưa tối ưu ở đâu đó
em post cả Code và file đính kèm ạ

Sub Sum_data()
    Dim SumArr(), Sarr()
    Dim i As Long, j As Long, l As Long, SoLuongBan As Long, TraLai As Long
    Dim SumLr As Long, SumLcol As Long, SLr As Long, SLcol As Long, TG As Double
    SoLuongBan = 0: TraLai = 0: TG = Timer()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    SumLr = Sheet1.Range("F" & Rows.Count).End(xlUp).Row
    SumLcol = Sheet1.Cells(11, Columns.Count).End(xlToLeft).Column
    SumArr = Sheet1.Range("A8").Resize(SumLr - 7, SumLcol).Value ' tu A8
    SLr = Sheet2.Range("E" & Rows.Count).End(xlUp).Row
    scol = Sheet2.Cells(8, Columns.Count).End(xlToLeft).Column
    Sarr = Sheet2.Range("E8").Resize(SLr - 7, scol - 4).Value ' tu E8
    For i = 5 To UBound(SumArr, 1)
        If SumArr(i, 1) = Empty And SumArr(i, 6) <> "" Then
            For j = 20 To UBound(SumArr, 2)
                For l = 2 To UBound(Sarr, 1)
                    If SumArr(i, 6) = Sarr(l, 5) And SumArr(1, j) = Sarr(l, 3) Then
                        If SumArr(4, j) = 1 Then
                            SoLuongBan = SumArr(i, j) + Sarr(l, 7)
                            SumArr(i, j) = SoLuongBan
                            SoLuongBan = 0
                        ElseIf SumArr(4, j) = 2 Then
                            TraLai = SumArr(i, j) + Sarr(l, 16)
                            SumArr(i, j) = TraLai
                            TraLai = 0
                        End If
                    End If
                Next l
            Next j
        End If
    Next i
    Sheet1.Range("A8").Resize(SumLr - 7, SumLcol) = SumArr
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "Done " & Round(Timer() - TG, 2)
End Sub

 

[BuiQuangThuan]

Code sịn sò thế kia mà vẫn treo cơ à

 

[snow25]

Code sịn sò thế kia mà vẫn treo cơ à

Code 3 vòng lặp lồng nhau nếu dữ liệu nhiều mỗi vòng lặp 10k lần thì nó chạy cần:10.000x10.000x10.000=1.000.000.000.000 câu lệnh để chạy hết vòng lặp chưa tính ở trong nó còn thêm điều kiện nữa.

 

[Vân Khánh 0802]

anh thử xem đúng chưa nhé
code chưa bẫy lỗi. 1.95s

Option Explicit
Sub ABC()
    Dim i As Integer, j As Integer, SumArr As Variant, DataArr As Variant
    Dim SumLr As Integer, SumLcol As Integer, DataLr As Integer, Dic As Object
    Dim DK, Temp, Item, SumRow As Integer, SumCol As Integer
    Dim SLBan As Double, SLTraLai As Double, Time As Double
    '-------------------------------------------------------------
    Time = Timer()
    With Sheet1
        SumLr = .Range("F" & .Rows.Count).End(xlUp).Row
        SumLcol = .Cells(8, .Columns.Count).End(xlToLeft).Column
        SumArr = .Range("A8").Resize(SumLr - 7, SumLcol).Value
    End With
    With Sheet2
        DataLr = .Range("C" & .Rows.Count).End(xlUp).Row
        DataArr = .Range("A10").Resize(DataLr - 9, 20).Value
    End With
    Set Dic = CreateObject("scripting.dictionary")
    '--------------------------------------------------------------
    For i = 6 To UBound(SumArr, 1)
        For j = 20 To UBound(SumArr, 2) Step 3
            If SumArr(i, 1) = "" Then
                If IsNumeric(SumArr(1, j)) Then
                    DK = SumArr(i, 6) & SumArr(1, j)
                    Dic.Add DK, i & "-" & j
                End If
            End If
        Next j
    Next i
    For i = 1 To UBound(DataArr, 1)
        DK = DataArr(i, 5) & DataArr(i, 3)
        If Dic.exists(DK) Then
            Item = Dic.Item(DK)
            Temp = Split(Item, "-")
            SumRow = Temp(0)
            SumCol = Temp(1)
            SLBan = DataArr(i, 7): SLTraLai = DataArr(i, 16)
            SumArr(SumRow, SumCol) = SumArr(SumRow, SumCol) + SLBan
            SumArr(SumRow, SumCol + 1) = SumArr(SumRow, SumCol + 1) + SLTraLai
        End If
    Next i
    Sheet1.Range("A8").Resize(SumLr - 7, SumLcol) = SumArr
    MsgBox "Done " & Round(Timer() - Time, 2) & " s", vbInformation, "VanKhanh0802"
End Sub

 

[hungvinh1402]

Đúng ý mình rồi. Cám ơn bạn.