Tạm rút gọn code thế này.
Sub tonghop()
Dim i As Long, j As Long, k As Long, sh, th
Set th = Worksheets("tonghop")
th.Range("F6:AO300").ClearContents
For Each sh In Worksheets
If sh.Name <> "tonghop" Then
For j = 6 To sh.[A6500].End(xlUp).Row
For i = 6 To th.[A6500].End(xlUp).Row
If th.Cells(i, 3) = sh.Cells(j, 3) Then
th.Range("F" & i & ":AO" & i).Value = sh.Range("F" & j & ":AO" & j).Value
Exit For
End If
Next
Next
End If
Next
End SubSub tonghop()
Dim i As Long, k As Long, ran As Range
Worksheets("tonghop").Range("F5:AO300").ClearContents
With Worksheets("tonghop").Range("A5:AO" & Worksheets("tonghop").[C6500].End(xlUp).Row - 1)
'lay tu HC
.AutoFilter 5, "HC"
i = 6
For Each ran In .Offset(1, 0).Resize(, 1).SpecialCells(12)
Worksheets("tonghop").Range("F" & ran.Row & ":AO" & ran.Row).Value = Worksheets("HC").Range("F" & i & ":AO" & i).Value
i = i + 1
Next
.AutoFilter
'lay tu A
.AutoFilter 5, "A" & "*"
i = 6
For Each ran In .Offset(1, 0).Resize(, 1).SpecialCells(12)
Worksheets("tonghop").Range("F" & ran.Row & ":AO" & ran.Row).Value = Worksheets("A").Range("F" & i & ":AO" & i).Value
i = i + 1
Next
.AutoFilter
[COLOR=#ff0000]'lay tu B
.AutoFilter 5, "B", xlOr, "AB"
i = 6
For Each ran In .Offset(1, 0).Resize(, 1).SpecialCells(12)
If ran(, 6) = "B" Then
Worksheets("tonghop").Range("F" & ran.Row & ":AO" & ran.Row).Value = Worksheets("B").Range("F" & i & ":AO" & i).Value
Else
For k = 6 To 41
Worksheets("tonghop").Cells(ran.Row, k) = Worksheets("tonghop").Cells(ran.Row, k) + Worksheets("B").Cells(i, k)
Next
End If
i = i + 1[/COLOR]
Next
.AutoFilter
End With
End SubThử code này xem sao nha
Sub tonghop()
Dim sh As Worksheet, i As Long, j As Long, n As Long
Dim nguon(), kq()
With Sheets("tonghop")
.[F6:AO300].ClearContents
kq = .Range(.[B6], .[B65536].End(3)).Resize(, 40).Value
For Each sh In Worksheets
If sh.Name <> "tonghop" Then
nguon = sh.Range(sh.[B6], sh.[B65536].End(3)).Resize(, 40).Value
For i = 1 To UBound(kq)
For j = 1 To UBound(nguon)
If nguon(j, 2) & nguon(j, 4) = kq(i, 2) & kq(i, 4) Then
For n = 5 To 40
kq(i, n) = kq(i, n) + nguon(j, n)
Next
End If
Next
Next
End If
Next
.[B6].Resize(i - 1, 40) = kq
End With
End SubNhờ giúp code mà nghe giống ra lệnh quá. Loạn thật.
Sub tonghop2()
Dim dic As Object
Dim sh As Worksheet, i As Long, j As Long, n As Long, k As Long, dk, dk2
Dim nguon(), dulieu(), kq()
Set dic = CreateObject("scripting.dictionary")
With Sheets("Tonghop")
nguon = .Range(.[B6], .[B65536].End(3)).Resize(, 40).Value
ReDim kq(1 To UBound(nguon), 1 To 40)
End With
For i = 1 To UBound(nguon)
dk = nguon(i, 2) & nguon(i, 4)
If Not dic.exists(dk) Then
k = k + 1
dic.Add dk, k
For n = 1 To 4
kq(k, n) = nguon(i, n)
Next
End If
Next
For Each sh In Worksheets
If sh.Name <> "Tonghop" Then
dulieu = sh.Range(sh.[B6], sh.[B65536].End(3)).Resize(, 40).Value
For j = 1 To UBound(dulieu)
dk2 = dulieu(j, 2) & dulieu(j, 4)
If dic.exists(dk2) Then
For n = 5 To 40
kq(dic.Item(dk2), n) = kq(dic.Item(dk2), n) + dulieu(j, n)
Next
End If
Next
End If
Next
Sheets("Tonghop").[B6].Resize(k, 40) = kq
End Sub
Option Explicit
Sub TongHopDT()
Dim Dic As Object, Sh As Worksheet
Dim Kq(), Tm, i, j, k
Set Dic = CreateObject("Scripting.Dictionary")
ReDim Kq(1 To Sheet1.[A65536].End(3).Row - 5, 1 To 42)
For Each Sh In Worksheets
Tm = Sh.Range("A6:AP" & Sh.[A65536].End(3).Row)
For i = 1 To UBound(Tm, 1)
If Sh.CodeName = "Sheet1" Then
Kq(i, 1) = i
For j = 2 To 5
Kq(i, j) = Tm(i, j)
Next
If Tm(i, 5) <> "" Then Dic.Add Tm(i, 3) & "@" & Tm(i, 5), i
Else
If Tm(i, 5) <> "" Then
For j = 6 To 42
If Tm(i, j) <> 0 Then Kq(Dic.Item(Tm(i, 3) & "@" & Tm(i, 5)), j) _
= Kq(Dic.Item(Tm(i, 3) & "@" & Tm(i, 5)), j) + Tm(i, j)
Next
End If
End If
Next
Next
Sheet1.Range("A6:AP6").Resize(UBound(Kq, 1)) = Kq
End SubĐúng rồi, đúng là mình muốn tăng tốc. Mình thì mới tìm hiểu về VBA với kiến thức hiện tại chưa thể rút gắn code và tăng tốc được, code viết ra còn thô sơ và nặng quá chỉ là giải quyết được công việc thôi nên một số đoạn code chạy lâu quá, có đoạn mất 40s àh.Nhưng mình sẽ học hỏi code hay trên diễn đàn và cải thiện dần dần vây!
Mình viết code theo cách để mình dễ hiểu theo cách làm của dic và mảng nhưng không hiểu sao lại báo lỗi dòng bôi đỏ.Giúp thêm mình với
Sub test()
Dim i As Long, j As Long, Kq, tim
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Worksheets("Tonghop")
.Range("F6:AP" & .[B6500].End(xlUp).Row).ClearContents
Kq = .Range("A6:AP" & .[B6500].End(xlUp).Row).Value
For i = 1 To UBound(Kq, 1)
If .Cells(i, 5) <> "" Then dic.Add .Cells(i, 3) & "@" & .Cells(i, 5), i
Next
End With
With Worksheets("HC")
tim = .Range("A6:AP" & .[B6500].End(xlUp).Row)
For i = 1 To UBound(tim, 1)
For j = 6 To 42
If tim(i, j) <> 0 Then Kq(dic.Item(tim(i, 3) & "@" & tim(i, 5)), j) = Kq(dic.Item(tim(i, 3) & "@" & tim(i, 5)), j) + tim(i, j)
Next
Next
End With
With Worksheets("A")
tim = .Range("A6:AP" & .[B6500].End(xlUp).Row)
For i = 1 To UBound(tim, 1)
For j = 6 To 42
If tim(i, j) <> 0 Then Kq(dic.Item(tim(i, 3) & "@" & tim(i, 5)), j) = Kq(dic.Item(tim(i, 3) & "@" & tim(i, 5)), j) + tim(i, j)
Next
Next
End With
With Worksheets("B")
tim = .Range("A6:AP" & .[B6500].End(xlUp).Row)
For i = 1 To UBound(tim, 1)
For j = 6 To 42
If tim(i, j) <> 0 Then [COLOR=#ff0000]Kq(dic.Item(tim(i, 3) & "@" & tim(i, 5)), j) = Kq(dic.Item(tim(i, 3) & "@" & tim(i, 5)), j) + tim(i, j)[/COLOR]
Next
Next
End With
Worksheets("tonghop").Range("A6:AP6").Resize(UBound(Kq, 1)) = Kq
Worksheets("tonghop").Range("A6:AP6").Resize(UBound(Kq, 1)).Select
End Sub
