Tổng hợp dữ liệu với điều kiện check (1 người xem)

[congtutapyeu]

Nhờ các anh chị giúp em tổng hợp dữ liệu trong file, yêu cầu em đã ghi rõ ràng trong file ạ.

Em xin chân thành cảm ơn!

 

[Quang_Hải]

Bạn xem file đính kèm

Sub tonghop_quanghai()
Dim d As Object, i, kq(1 To 20000, 1 To 10), dl(), x, k, dk, sh As WorkSheet
Set d = CreateObject("scripting.dictionary")
For Each sh In Worksheets
   If sh.Name <> "Tonghop" Then
      If UCase(sh.[B6]) = "X" Then
         dl = sh.Range(sh.[b10], sh.[b65536].End(3)).Resize(, 9).Value
         For i = 1 To UBound(dl)
            dk = dl(i, 1) & dl(i, 2)
            If Not d.exists(dk) Then
               k = k + 1
               d.Add dk, k
               kq(k, 1) = k: kq(k, 9) = "DT" & sh.[J6]
               For x = 2 To 8
                  kq(k, x) = dl(i, x - 1)
               Next
            Else
               For x = 5 To 8
                  kq(d.Item(dk), x) = kq(d.Item(dk), x) + dl(i, x - 1)
               Next
               kq(d.Item(dk), 9) = kq(d.Item(dk), 9) & "," & "DT" & sh.[J6]
            End If
         Next
      End If
   End If
Next
Sheets("Tonghop").[a10:j20000].ClearContents
Sheets("Tonghop").[a10].Resize(k, 9) = kq
End Sub

 

[Ba Tê]

Nhờ các anh chị giúp em tổng hợp dữ liệu trong file, yêu cầu em đã ghi rõ ràng trong file ạ.

Em xin chân thành cảm ơn!

Thử với code này xem, còn hơi bị rối với cột I.

Public Sub GPE()
Dim WS As Worksheet, Dic As Object, Rng(), Tem As String, Txt As String
Dim Arr(1 To 65000, 1 To 9), I As Long, J As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
For Each WS In Worksheets
    If WS.Name <> "TongHop" Then
        Rng = WS.Range(WS.[A10], WS.[A65000].End(xlUp)).Resize(, 8).Value
        If WS.[B6].Value <> "" Then
            Txt = "DT" & WS.[J6].Value & ". "
            For I = 1 To UBound(Rng, 1)
                Tem = Rng(I, 2) & Rng(I, 3)
                If Not Dic.Exists(Tem) Then
                    K = K + 1: Arr(K, 1) = K: Arr(K, 9) = Arr(K, 9) & Txt
                    Dic.Add Tem, K
                    For J = 2 To 8
                        Arr(K, J) = Rng(I, J)
                    Next J
                Else
                        Arr(Dic.Item(Tem), 9) = Arr(Dic.Item(Tem), 9) & Txt
                    For J = 5 To 8
                        Arr(Dic.Item(Tem), J) = Arr(Dic.Item(Tem), J) + Rng(I, J)
                    Next J
                End If
            Next I
        End If
    End If
Next
    With Sheets("TongHop")
        .[A10:I65000].ClearContents
        If K Then .[A10].Resize(K, 9).Value = Arr
    End With
Set Dic = Nothing
End Sub

Quang Hải lẹ quá ta?

 

[Quang_Hải]

Thử với code này xem, còn hơi bị rối với cột I.

Public Sub GPE() Dim WS As Worksheet, Dic As Object, Rng(), Tem As String, Txt As String Dim Arr(1 To 65000, 1 To 9), I As Long, J As Long, K As Long Set Dic = CreateObject("Scripting.Dictionary") For Each WS In Worksheets     If WS.Name  "TongHop" Then         Rng = WS.Range(WS.[A10], WS.[A65000].End(xlUp)).Resize(, 8).Value         If WS.[B6].Value  "" Then             Txt = "DT" & WS.[J6].Value & ". "             For I = 1 To UBound(Rng, 1)                 Tem = Rng(I, 2) & Rng(I, 3)                 If Not Dic.Exists(Tem) Then                     K = K + 1: Arr(K, 1) = K: Arr(K, 9) = Arr(K, 9) & Txt                     Dic.Add Tem, K                     For J = 2 To 8                         Arr(K, J) = Rng(I, J)                     Next J                 Else                         Arr(Dic.Item(Tem), 9) = Arr(Dic.Item(Tem), 9) & Txt                     For J = 5 To 8                         Arr(Dic.Item(Tem), J) = Arr(Dic.Item(Tem), J) + Rng(I, J)                     Next J                 End If             Next I         End If     End If Next     With Sheets("TongHop")         .[A10:I65000].ClearContents         If K Then .[A10].Resize(K, 9).Value = Arr     End With Set Dic = Nothing End Sub

Quang Hải lẹ quá ta?

Em có ý tưởng cũng giống y chang anh, có lẽ code của em được học của anh nhiều nên mới giống như thế Hình như anh quên mất thêm cái sự kiện Activate cho sheet Tonghop rồi

 

[Ba Tê]

Em có ý tưởng cũng giống y chang anh, có lẽ code của em được học của anh nhiều nên mới giống như thế Hình như anh quên mất thêm cái sự kiện Activate cho sheet Tonghop rồi

Chỉ viết code thôi, còn sử dụng bằng cách nào thì để tác giả tự làm mà.

Sheets("Tonghop").[a10].Resize(k, 9) = kq

Cái này nếu không có sheet nào có check thì lỗi (K=0)!