Xin giúp mã tổng hợp dữ liệu từ 2 sheet thành 1 sheet.

[theanhst92]

Kính chào mọi người ạ.
Em có một đề tài vẫn được mọi người giúp đỡ, hiện tại e đang có dữ liệu 2 sheet và muốn tổng hợp lại thành 1 sheet
Em xin diễn tả như sau ạ.
Dữ liệu 1:

Data 2:

Kết quả:

 

[snow25]

Kính chào mọi người ạ.
Em có một đề tài vẫn được mọi người giúp đỡ, hiện tại e đang có dữ liệu 2 sheet và muốn tổng hợp lại thành 1 sheet
Em xin diễn tả như sau ạ.
Dữ liệu 1:
View attachment 251292
Data 2:
View attachment 251293
Kết quả:
View attachment 251294

Bạn thử code.

Sub tonghop()
    Dim i As Long, lr As Long, dic As Object, dk As String, kq, data, arr, T, a As Long, j As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("chitiet")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("B5:M" & lr).Value
         For i = 1 To UBound(arr)
             dk = arr(i, 2) & "#" & arr(i, 3)
             If Not dic.exists(dk) Then
                dic.Add dk, i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
         Next i
   End With
   With Sheets("tonghop")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        data = .Range("a3:I" & lr).Value
        ReDim kq(1 To UBound(arr) + UBound(data), 1 To 12)
        For i = 1 To UBound(data)
            dk = data(i, 2) & "#" & data(i, 3)
            If Not dic.exists(dk) Then
               a = a + 1
               For j = 1 To 6
                   kq(a, j) = data(i, j)
               Next j
           Else
              For Each T In Split(dic.Item(dk), "#")
                  a = a + 1
                  For j = 1 To 12
                      kq(a, j) = arr(T, j)
                  Next j
             Next
          End If
      Next i
  End With
  With Sheets("kq")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 1 Then .Range("a2:l" & lr).ClearContents
       .Range("a2:l2").Resize(a).Value = kq
  End With
  Set dic = Nothing
End Sub

 

[theanhst92]

Em cảm ơn bác đã giúp đỡ. mã trên chạy khá nhanh và dễ hiểu nhưng em có 1 thắc mắc sau là tại sao khi dữ liệu nguồn là dạng table thì hàm lại bị lỗi ạ.

 

[snow25]

Em cảm ơn bác đã giúp đỡ. mã trên chạy khá nhanh và dễ hiểu nhưng em có 1 thắc mắc sau là tại sao khi dữ liệu nguồn là dạng table thì hàm lại bị lỗi ạ.

Bạn thử cái này.

Sub tonghop()
    Dim i As Long, lr As Long, dic As Object, dk As String, kq, data, arr, T, a As Long, j As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("chitiet")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("B5:P" & lr).Value
         For i = 1 To UBound(arr)
             dk = arr(i, 2) & "#" & arr(i, 3)
             If Len(dk) > 1 Then
             If Not dic.exists(dk) Then
                dic.Add dk, i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
             End If
         Next i
   End With
   With Sheets("tonghop")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        data = .Range("a3:I" & lr).Value
        ReDim kq(1 To UBound(arr) + UBound(data), 1 To 18)
        For i = 1 To UBound(data)
            dk = data(i, 2) & "#" & data(i, 3)
            If Len(dk) > 1 Then
            If Not dic.exists(dk) Then
               a = a + 1
               For j = 1 To 9
                   kq(a, j) = data(i, j)
               Next j
                    kq(a, 12) = data(i, 4)
           Else
              For Each T In Split(dic.Item(dk), "#")
                  a = a + 1
                  For j = 1 To 6
                      kq(a, j) = arr(T, j)
                  Next j
                      kq(a, 10) = arr(T, 7)
                      kq(a, 11) = arr(T, 8)
                      kq(a, 12) = arr(T, 9)
                      kq(a, 13) = arr(T, 10)
                      kq(a, 14) = arr(T, 11)
                      kq(a, 15) = arr(T, 12)
                      kq(a, 16) = arr(T, 13)
                      kq(a, 17) = arr(T, 14)
                      kq(a, 18) = arr(T, 15)
                Next
          End If
          End If
      Next i
  End With
  With Sheets("kq")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 1 Then .Range("A2:R" & lr).ClearContents
       .Range("A2:R2").Resize(a).Value = kq
  End With
  Set dic = Nothing
End Sub

 

[theanhst92]

Thêm điều kiện IF trước khi chạy đã khắc phục được lỗi rồi ạ. Em cảm ơn bác ạ!

Bạn thử cái này.

Sub tonghop()
    Dim i As Long, lr As Long, dic As Object, dk As String, kq, data, arr, T, a As Long, j As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("chitiet")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("B5:P" & lr).Value
         For i = 1 To UBound(arr)
             dk = arr(i, 2) & "#" & arr(i, 3)
             If Len(dk) > 1 Then
             If Not dic.exists(dk) Then
                dic.Add dk, i
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
             End If
         Next i
   End With
   With Sheets("tonghop")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        data = .Range("a3:I" & lr).Value
        ReDim kq(1 To UBound(arr) + UBound(data), 1 To 18)
        For i = 1 To UBound(data)
            dk = data(i, 2) & "#" & data(i, 3)
            If Len(dk) > 1 Then
            If Not dic.exists(dk) Then
               a = a + 1
               For j = 1 To 9
                   kq(a, j) = data(i, j)
               Next j
                    kq(a, 12) = data(i, 4)
           Else
              For Each T In Split(dic.Item(dk), "#")
                  a = a + 1
                  For j = 1 To 6
                      kq(a, j) = arr(T, j)
                  Next j
                      kq(a, 10) = arr(T, 7)
                      kq(a, 11) = arr(T, 8)
                      kq(a, 12) = arr(T, 9)
                      kq(a, 13) = arr(T, 10)
                      kq(a, 14) = arr(T, 11)
                      kq(a, 15) = arr(T, 12)
                      kq(a, 16) = arr(T, 13)
                      kq(a, 17) = arr(T, 14)
                      kq(a, 18) = arr(T, 15)
                Next
          End If
          End If
      Next i
  End With
  With Sheets("kq")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 1 Then .Range("A2:R" & lr).ClearContents
       .Range("A2:R2").Resize(a).Value = kq
  End With
  Set dic = Nothing
End Sub