Nhờ giúp đỡ code tổng hợp dữ liệu từ danh sách phụ thuộc vào danh sách khác

Shaa · 9/7/24

Em chào các anh/chị,
Em đang gặp trường hợp cần tổng hợp ra dữ liệu từ một danh sách, trong đó dữ liệu theo cặp sẽ thay đổi khi nó có tồn tại cặp dữ liệu khác.
Hơi khó diễn đạt nên em sẽ gửi ảnh và giải thích trong tệp đính kèm
Anh/chị giúp đỡ em với nhé
Em cảm ơn ạ!

snow25 · 9/7/24

Shaa đã viết:
Em chào các anh/chị,
Em đang gặp trường hợp cần tổng hợp ra dữ liệu từ một danh sách, trong đó dữ liệu theo cặp sẽ thay đổi khi nó có tồn tại cặp dữ liệu khác.
Hơi khó diễn đạt nên em sẽ gửi ảnh và giải thích trong tệp đính kèm
Anh/chị giúp đỡ em với nhé
Em cảm ơn ạ!

Dữ liệu đúng như trên thì chạy code này hên sui.

Mã:

Sub abc()
    Dim i As Long, lr As Long, dic As Object, arr, kq, dk As String, T(), k As Integer, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A4:B" & lr).Value
         ReDim kq(1 To UBound(arr) * 10, 1 To 2)
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, Array(arr(i, 2))
             Else
                T = dic.Item(dk)
                ReDim Preserve T(0 To UBound(T) + 1)
                T(UBound(T)) = arr(i, 2)
                dic.Item(dk) = T
             End If
         Next i
         For i = 1 To UBound(arr)
             dk = arr(i, 2)
             If dic.exists(dk) Then
                T = dic.Item(dk)
                For k = 0 To UBound(T)
                    a = a + 1
                    kq(a, 1) = arr(i, 1)
                    kq(a, 2) = T(k)
                Next k
             Else
                a = a + 1
                kq(a, 1) = arr(i, 1)
                kq(a, 2) = arr(i, 2)
             End If
         Next i
         .Range("F4:G1000").ClearContents
         .Range("F4:G4").Resize(a).Value = kq
   End With
   Set dic = Nothing
End Sub

Shaa · 9/7/24

snow25 đã viết:

Dữ liệu đúng như trên thì chạy code này hên sui.

Mã:

Sub abc()
    Dim i As Long, lr As Long, dic As Object, arr, kq, dk As String, T(), k As Integer, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A4:B" & lr).Value
         ReDim kq(1 To UBound(arr) * 10, 1 To 2)
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                dic.Add dk, Array(arr(i, 2))
             Else
                T = dic.Item(dk)
                ReDim Preserve T(0 To UBound(T) + 1)
                T(UBound(T)) = arr(i, 2)
                dic.Item(dk) = T
             End If
         Next i
         For i = 1 To UBound(arr)
             dk = arr(i, 2)
             If dic.exists(dk) Then
                T = dic.Item(dk)
                For k = 0 To UBound(T)
                    a = a + 1
                    kq(a, 1) = arr(i, 1)
                    kq(a, 2) = T(k)
                Next k
             Else
                a = a + 1
                kq(a, 1) = arr(i, 1)
                kq(a, 2) = arr(i, 2)
             End If
         Next i
         .Range("F4:G1000").ClearContents
         .Range("F4:G4").Resize(a).Value = kq
   End With
   Set dic = Nothing
End Sub

Em thấy kết quả ra đúng rồi ạ
Em cảm ơn bác rất nhiều

HieuCD · 9/7/24

Shaa đã viết:
Em chào các anh/chị,
Em đang gặp trường hợp cần tổng hợp ra dữ liệu từ một danh sách, trong đó dữ liệu theo cặp sẽ thay đổi khi nó có tồn tại cặp dữ liệu khác.
Hơi khó diễn đạt nên em sẽ gửi ảnh và giải thích trong tệp đính kèm
Anh/chị giúp đỡ em với nhé
Em cảm ơn ạ!

Nếu có hơn 3 cấp độ cần dùng code đệ quy
Ví dụ linh kiện nhỏ a1 lại có linh kiện bé a11 vàlinh kiện bé a12

Mã:

Sub xyz()
  Dim arr(), res(), S, dic As Object, key$, sRow&, i&, j&, k&
  
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("sheet1")
    arr = .Range("A4", .Range("B" & Rows.Count).End(xlUp)).Value
    .Range("F4:G1000").ClearContents
  End With
 
  sRow = UBound(arr)
  For i = 1 To sRow
    dic(arr(i, 1)) = dic(arr(i, 1)) & "|" & arr(i, 2)
  Next i
 
  ReDim res(1 To sRow * 10, 1 To 2)
  For i = 1 To sRow
    If key <> arr(i, 1) Then
      Call DeQuy(dic, arr, res, k, arr(i, 1), Split(dic(arr(i, 1)), "|"))
      key = arr(i, 1) 
    End If
  Next i
  Sheets("sheet1").Range("F4:G4").Resize(k).Value = res
End Sub

Sub DeQuy(dic, arr, res, k, sp, ByVal S)
  Dim j&
 
  For j = 1 To UBound(S)
    If dic.exists(S(j)) Then
      Call DeQuy(dic, arr, res, k, sp, Split(dic(S(j)), "|"))
    Else
      k = k + 1
      res(k, 1) = sp
      res(k, 2) = S(j)
    End If
  Next j
End Sub

Trần Văn Bình · 10/7/24

HieuCD đã viết:

Nếu có hơn 3 cấp độ cần dùng code đệ quy
Ví dụ linh kiện nhỏ a1 lại có linh kiện bé a11 vàlinh kiện bé a12

Mã:

Sub xyz()
  Dim arr(), res(), S, dic As Object, key$, sRow&, i&, j&, k&
   
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("sheet1")
    arr = .Range("A4", .Range("B" & Rows.Count).End(xlUp)).Value
    .Range("F4:G1000").ClearContents
  End With
 
  sRow = UBound(arr)
  For i = 1 To sRow
    dic(arr(i, 1)) = dic(arr(i, 1)) & "|" & arr(i, 2)
  Next i
 
  ReDim res(1 To sRow * 10, 1 To 2)
  For i = 1 To sRow
    If key <> arr(i, 1) Then
      Call DeQuy(dic, arr, res, k, arr(i, 1), Split(dic(arr(i, 1)), "|"))
      key = arr(i, 1)
    End If
  Next i
  Sheets("sheet1").Range("F4:G4").Resize(k).Value = res
End Sub

Sub DeQuy(dic, arr, res, k, sp, ByVal S)
  Dim j&
 
  For j = 1 To UBound(S)
    If dic.exists(S(j)) Then
      Call DeQuy(dic, arr, res, k, sp, Split(dic(S(j)), "|"))
    Else
      k = k + 1
      res(k, 1) = sp
      res(k, 2) = S(j)
    End If
  Next j
End Sub

MÌnh Text nếu copy cột A, cột B cùng tên hàng, cùng sản phẩm thì bị thành 3 kết quả

Shaa · 10/7/24

HieuCD đã viết:

Nếu có hơn 3 cấp độ cần dùng code đệ quy
Ví dụ linh kiện nhỏ a1 lại có linh kiện bé a11 vàlinh kiện bé a12

Mã:

Sub xyz()
  Dim arr(), res(), S, dic As Object, key$, sRow&, i&, j&, k&
   
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("sheet1")
    arr = .Range("A4", .Range("B" & Rows.Count).End(xlUp)).Value
    .Range("F4:G1000").ClearContents
  End With
 
  sRow = UBound(arr)
  For i = 1 To sRow
    dic(arr(i, 1)) = dic(arr(i, 1)) & "|" & arr(i, 2)
  Next i
 
  ReDim res(1 To sRow * 10, 1 To 2)
  For i = 1 To sRow
    If key <> arr(i, 1) Then
      Call DeQuy(dic, arr, res, k, arr(i, 1), Split(dic(arr(i, 1)), "|"))
      key = arr(i, 1)
    End If
  Next i
  Sheets("sheet1").Range("F4:G4").Resize(k).Value = res
End Sub

Sub DeQuy(dic, arr, res, k, sp, ByVal S)
  Dim j&
 
  For j = 1 To UBound(S)
    If dic.exists(S(j)) Then
      Call DeQuy(dic, arr, res, k, sp, Split(dic(S(j)), "|"))
    Else
      k = k + 1
      res(k, 1) = sp
      res(k, 2) = S(j)
    End If
  Next j
End Sub

vâng thưa bác,
em sẽ thử áp dụng ạ, đôi khi thực tế có nhiều trường hợp phát sinh, bác rất cẩn thận
Em cảm ơn bác rất nhiều ạ

HieuCD · 10/7/24

Trần Văn Bình đã viết:
MÌnh Text nếu copy cột A, cột B cùng tên hàng, cùng sản phẩm thì bị thành 3 kết quả

Code mình viết cho dữ liệu xếp gần nhau
If key <> arr(i, 1) Then . . .
Nếu copy dữ liệu lung tung thì kết quả sẽ lung tung

Nhờ giúp đỡ code tổng hợp dữ liệu từ danh sách phụ thuộc vào danh sách khác

Shaa

Thành viên mới

File đính kèm

snow25

Thành viên gạo cội

Shaa

Thành viên mới

HieuCD

Chuyên gia GPE

Trần Văn Bình

GTVT

Shaa

Thành viên mới

HieuCD

Chuyên gia GPE

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian