nhờ anh chị, chú bác giúp em gom gọn phần code phía dưới giúp em. Sao bị lỗi ở dòng 24, 25, 26 nữa ạ. em cám ơn (1 người xem)

[A HOANG 620]

em nhờ anh chị, chú bác gom giúp em đoạn code cho ngắn gọn dưới đây và khắc phục lỗi ở dòng 24, 25, 26 với ạ. em cám ơn

Sub ABC()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Dic As Object
Dim Nguon(), Kq(), Key, ViTri, SoLan
Dim Dong, Irow, a As Long
Dim Tmr As Double, j As Long, W As Integer, Rws As Long
Dim arr(), aDL()

Set Dic = CreateObject("Scripting.Dictionary")
'------------------------------------------------------------------------------------------------------------------------------
'phan tinh cot A, cot B, cot C, cot E, cot F, cot G, cot H, cot D duoc trich tu sheet DMHH o phan duoi
With Sheets("Bao Cao")
Irow = .Range("B" & Rows.Count).End(xlUp).Row
Nguon = .Range("C5").Resize(Irow, 11).Value
End With

Irow = UBound(Nguon)


ReDim Kq(1 To Irow, 1 To 8)
For a = 1 To Irow - 1

Key = Nguon(a, 1) & "#" & Nguon(a, 2) & "#" & Nguon(a, 3) & "#" & Nguon(a, 6)
If Not Dic.exists(Key) Then

Dong = Dong + 1

Dic.Add Key, Dong
Kq(Dong, 1) = Nguon(a, 1)
Kq(Dong, 2) = Nguon(a, 2)
Kq(Dong, 3) = Nguon(a, 3)
Kq(Dong, 5) = Nguon(a, 6)
Kq(Dong, 6) = Nguon(a, 9)
Kq(Dong, 7) = Nguon(a, 10)
Kq(Dong, 8) = Nguon(a, 11)

Else

ViTri = Dic.Item(Key)
Kq(ViTri, 6) = Kq(ViTri, 6) + Nguon(a, 9)
Kq(ViTri, 7) = Kq(ViTri, 7) + Nguon(a, 10)
Kq(ViTri, 8) = Kq(ViTri, 8) + Nguon(a, 11)

End If

Next

With Sheets("TH Ton")
If Dong > 0 Then
.Range("A510000").ClearContents
.Range("A5").Resize(Dong, 8).Value = Kq
End If
End With
'-----------------------------------------------------------------
'phan trich loc tu sheet DMHH cho cot D
Rws = Sheets("TH Ton").Range("C" & Rows.Count).End(xlUp).Row
Kq() = Sheets("TH Ton").Range("C5" & Rws).Value

W = Sheets("DMHH").Range("B" & Rows.Count).End(xlUp).Row
aDL() = Sheets("DMHH").Range("B4").Resize(W, 7).Value
For j = 1 To UBound(Kq())
For W = 1 To UBound(aDL())
If UCase$(Kq(j, 1)) = UCase$(aDL(W, 1)) Then
Kq(j, 2) = aDL(W, 7)

End If
Next W

Next j
Sheets("TH Ton").Range("C5").Resize(Rws - 1, 2).Value = Kq()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[BuiQuangThuan]

em nhờ anh chị, chú bác gom giúp em đoạn code cho ngắn gọn dưới đây và khắc phục lỗi ở dòng 24, 25, 26 với ạ. em cám ơn

Bác nên đưa code vào thẻ code. và nó lỗi như nào thì mô tả rõ hơn được không?
Sửa như vậy xem kết quả đúng không?

Sub ABC()
    Application.ScreenUpdating = False
    Dim Dic As Object
    Dim Nguon(), Kq(), Key, ViTri, SoLan
    Dim Dong, Irow, a As Long
    Dim Tmr As Double, j As Long, W As Integer, Rws As Long
    Dim arr(), aDL()
    Set Dic = CreateObject("Scripting.Dictionary")
    '------------------------------------------------------------------------------------------------------------------------------
    'phan tinh cot A, cot B, cot C, cot E, cot F, cot G, cot H, cot D duoc trich tu sheet DMHH o phan duoi
    With Sheets("Bao Cao")
        Irow = .Range("B" & Rows.Count).End(xlUp).Row
        Nguon = .Range("C5").Resize(Irow, 11).Value
    End With
    Irow = UBound(Nguon)
    ReDim Kq(1 To Irow, 1 To 8)
    For a = 1 To Irow - 1
        If Nguon(a, 2) <> Empty Then
            Key = Nguon(a, 1) & "#" & Nguon(a, 2) & "#" & Nguon(a, 3) & "#" & Nguon(a, 6)
            If Not Dic.exists(Key) Then
                Dong = Dong + 1
                Dic.Add Key, Dong
                Kq(Dong, 1) = Nguon(a, 1)
                Kq(Dong, 2) = Nguon(a, 2)
                Kq(Dong, 3) = Nguon(a, 3)
                Kq(Dong, 5) = Nguon(a, 6)
                Kq(Dong, 6) = Nguon(a, 9)
                Kq(Dong, 7) = Nguon(a, 10)
                Kq(Dong, 8) = Nguon(a, 11)
            Else
                ViTri = Dic.Item(Key)
                Kq(ViTri, 6) = Kq(ViTri, 6) + Nguon(a, 9)
                Kq(ViTri, 7) = Kq(ViTri, 7) + Nguon(a, 10)
                Kq(ViTri, 8) = Kq(ViTri, 8) + Nguon(a, 11)
            End If
        End If
    Next
    With Sheets("TH Ton")
        If Dong > 0 Then
            .Range("A5:P10000").ClearContents
            .Range("A5").Resize(Dong, 8).Value = Kq
        End If
    End With
    '-----------------------------------------------------------------
    'phan trich loc tu sheet DMHH cho cot D
    Rws = Sheets("TH Ton").Range("C" & Rows.Count).End(xlUp).Row
    Kq() = Sheets("TH Ton").Range("C5:D" & Rws).Value
    W = Sheets("DMHH").Range("B" & Rows.Count).End(xlUp).Row
    aDL() = Sheets("DMHH").Range("B4").Resize(W, 7).Value
    For j = 1 To UBound(Kq())
        For W = 1 To UBound(aDL())
            If UCase$(Kq(j, 1)) = UCase$(aDL(W, 1)) Then
                Kq(j, 2) = aDL(W, 7)
            End If
        Next W
    Next j
    Sheets("TH Ton").Range("C5").Resize(UBound(Kq), 2).Value = Kq()
    Application.ScreenUpdating = True
    MsgBox "OK"
End Sub

 

[HUONGHCKT]

em nhờ anh chị, chú bác gom giúp em đoạn code cho ngắn gọn dưới đây và khắc phục lỗi ở dòng 24, 25, 26 với ạ. em cám ơn

Mạo muội tác giả code. nếu có gì khiếm khuyết xin được lượng thứ.
Thử thay code cũ bằng code này và chạy thử.

Option Explicit

Sub ABC()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
       Dim Dic As Object, Dict As Object
       Dim Nguon(), Kq(), Key, ViTri, SoLan
       Dim Dong, Irow, a As Long, R&, j&, i&
        Dim Tmr As Double, W As Integer, Rws As Long
        Dim arr(), aDL(), Col(), S
    
       Set Dic = CreateObject("Scripting.Dictionary")
  '------------------------------------------------------------------------------------------------------------------------------
  'phan tinh cot A, cot B, cot C, cot E, cot F, cot G, cot H, cot D duoc trich tu sheet DMHH o phan duoi
       With Sheets("Bao Cao")
               Irow = .Range("B" & Rows.Count).End(xlUp).Row
               Nguon = .Range("C5:M" & Irow).Value
       End With
       With Sheets("DMHH")
            W = .Range("B" & Rows.Count).End(xlUp).Row
            aDL() = .Range("B4").Resize(W, 7).Value
       End With
     Set Dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(aDL)
        If aDL(i, 1) <> Empty Then
            Key = aDL(i, 1)
            If Not Dict.Exists(Key) Then Dict(Key) = i
        End If
    Next i

    Col = Array(, 1, 2, 3, , 6, 9, 10, 11)
       R = UBound(Nguon)
       ReDim Kq(1 To R, 1 To 8)
       For a = 1 To R
            Key = Nguon(a, 1) & "#" & Nguon(a, 2) & "#" & Nguon(a, 3) & "#" & Nguon(a, 6)
            S = Split(Key, "#")
            If Not Dic.Exists(Key) Then
               Dong = Dong + 1
               Dic.Add Key, Dong
                For j = 1 To 8
                    If j <> 4 Then Kq(Dong, j) = Nguon(a, Col(j))
                Next j
                If Dict.Exists(S(2)) Then Kq(Dong, 4) = aDL(Dict(S(2)), 7)
            Else
              ViTri = Dic.Item(Key)
              Kq(ViTri, 6) = Kq(ViTri, 6) + Nguon(a, 9)
              Kq(ViTri, 7) = Kq(ViTri, 7) + Nguon(a, 10)
              Kq(ViTri, 8) = Kq(ViTri, 8) + Nguon(a, 11)
            End If
       Next
    
       With Sheets("TH Ton")
            If Dong Then
                .Range("A5:P10000").ClearContents
                .Range("A5").Resize(Dong, 8) = Kq
            End If
       End With
Set Dic = Nothing
Set Dict = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox " Xong rôi!"
End Sub

 

[Hoàng Tuấn 868]

có gì khiếm khuyết xin được lượng thứ.

Nghe câu này lại cứ tưởng ...