Giúp em VBA xác định những mặt hàng giống công thức với nhau

[bap226]

Em có 1 file dữ liệu quản lý mặt hàng và các thành phần nguyên liệu, khối lượng trong mỗi mặt hàng. Dữ liệu khoảng 1500 mặt hàng với khoảng 70000 dòng.
Em cần giúp VBA xác nhận những mặt hàng nào giống công thức với nhau theo 2 trường hợp:
1. Giống nhau về thành phần nguyên liệu
2. Giống nhau về cả thành phần nguyên liệu và khối lượng
Chỉ cần kiểm tra nguyên liệu giống nhau, bỏ qua vị trí đứng của nguyên liệu trong mỗi công thức (vị trí nguyên liệu có thể khác nhau)
Có thể đánh dấu cùng một số ở bảng kết quả để nhận biết mặt hàng giống công thức
Em đính kèm theo file mẫu
Em cảm ơn

 

[HieuCD]

Em có 1 file dữ liệu quản lý mặt hàng và các thành phần nguyên liệu, khối lượng trong mỗi mặt hàng. Dữ liệu khoảng 1500 mặt hàng với khoảng 70000 dòng.
Em cần giúp VBA xác nhận những mặt hàng nào giống công thức với nhau theo 2 trường hợp:
1. Giống nhau về thành phần nguyên liệu
2. Giống nhau về cả thành phần nguyên liệu và khối lượng
Chỉ cần kiểm tra nguyên liệu giống nhau, bỏ qua vị trí đứng của nguyên liệu trong mỗi công thức (vị trí nguyên liệu có thể khác nhau)
Có thể đánh dấu cùng một số ở bảng kết quả để nhận biết mặt hàng giống công thức
Em đính kèm theo file mẫu
Em cảm ơn

Kiểm tra lại . . .

Option Explicit
Sub xyz()
  Dim sArr(), aNL, aKL, res(), ma$, tmp$
  Dim sRow&, i&, r&, k&, N&, c&, c2&
 
  i = Range("B" & Rows.Count).End(xlUp).Row
  If i < 2 Then MsgBox ("khong co du lieu!"): Exit Sub
  sArr = Range("B2:G" & i + 1).Value
  sRow = UBound(sArr) - 1
  ReDim res(1 To sRow, 1 To 6)
 
  For i = 1 To sRow
    If ma <> sArr(i, 1) Then
      k = k + 1
      ma = sArr(i, 1)
      res(k, 1) = sArr(i, 1)
      res(k, 2) = sArr(i, 2)
      N = 0
      aNL = Array(sArr(i, 3))
      aKL = Array(sArr(i, 6))
    Else
      N = N + 1
      ReDim Preserve aNL(0 To N)
      aNL(N) = sArr(i, 3)
      ReDim Preserve aKL(0 To N)
      aKL(N) = sArr(i, 6)
    End If
    If ma <> sArr(i + 1, 1) Then
      Call Sort_Arr(res, k, aNL, aKL, N)
    End If
  Next i

  c = 1: c2 = 1
  res(1, 3) = c: res(1, 4) = c2
  For i = 2 To k
    tmp = res(i, 5)
    For r = 1 To i - 1
      If tmp = res(r, 5) Then
        res(i, 3) = res(r, 3)
        Exit For
      End If
    Next r
    If r = i Then
      c = c + 1
      res(i, 3) = c
    End If
    
    tmp = res(i, 5) & "|" & res(i, 6)
    For r = 1 To i - 1
      If tmp = res(r, 5) & "|" & res(r, 6) Then
        res(i, 4) = res(r, 4)
        Exit For
      End If
    Next r
    If r = i Then
      c2 = c2 + 1
      res(i, 4) = c2
    End If
  Next i
  Range("J2").Resize(k, 4) = res
End Sub

Private Sub Sort_Arr(res, k, aNL, aKL, N)
  Dim arr, arr2, c&(), tmp$, sRow&, fR&, i&, r&

  arr = aNL: arr2 = aKL
  ReDim c(0 To N)
  For i = 0 To N - 1
    tmp = arr(i)
    For r = i + 1 To N
      If tmp > arr(r) Then c(i) = c(i) + 1 Else c(r) = c(r) + 1
    Next r
  Next i
  For i = 0 To N
    aNL(c(i)) = arr(i)
    aKL(c(i)) = arr2(i)
  Next i
  res(k, 5) = Join(aNL, "|")
  res(k, 6) = Join(aKL, "|")
End Sub

 

[snow25]

Em có 1 file dữ liệu quản lý mặt hàng và các thành phần nguyên liệu, khối lượng trong mỗi mặt hàng. Dữ liệu khoảng 1500 mặt hàng với khoảng 70000 dòng.
Em cần giúp VBA xác nhận những mặt hàng nào giống công thức với nhau theo 2 trường hợp:
1. Giống nhau về thành phần nguyên liệu
2. Giống nhau về cả thành phần nguyên liệu và khối lượng
Chỉ cần kiểm tra nguyên liệu giống nhau, bỏ qua vị trí đứng của nguyên liệu trong mỗi công thức (vị trí nguyên liệu có thể khác nhau)
Có thể đánh dấu cùng một số ở bảng kết quả để nhận biết mặt hàng giống công thức
Em đính kèm theo file mẫu
Em cảm ơn

Thử code.

Sub laygiatri()
   Dim i As Long, arr, dic As Object, kq, lr, oSList As Object, dk As String, k As Long, T, j As Long, a As Long, c As Long, d As Long
   Dim b As Integer, m As Long, dks As String
   Set oSList = CreateObject("System.Collections.SortedList")
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("sheet1")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       arr = .Range("B2:G" & lr).Value
       ReDim Data(1 To UBound(arr), 1 To 6)
       ReDim kq(1 To UBound(arr), 1 To 6)
       For i = 1 To UBound(arr)
           dks = arr(i, 1)
           If Not dic.exists(dks) Then
              m = m + 1
              dic.Add dks, m
              kq(m, 1) = arr(i, 1)
              kq(m, 2) = arr(i, 2)
           End If
           dk = arr(i, 3)
           If Not oSList.Contains(dk) Then
              oSList.Add dk, i
           Else
              oSList.Item(dk) = oSList.Item(dk) & "#" & i
           End If
       Next i
       For k = 0 To oSList.Count - 1
           For Each T In Split(oSList.GetByIndex(k), "#")
               a = a + 1
               For j = 1 To 6
                   Data(a, j) = arr(T, j)
               Next j
           Next
       Next k
       For i = 1 To UBound(arr)
             dk = Data(i, 1)
              b = dic.Item(dk)
              kq(b, 5) = kq(b, 5) & "#" & Data(i, 3)
              kq(b, 6) = kq(b, 6) & "#" & Data(i, 3) & "#" & Data(i, 6)
       Next i
      For i = 1 To m
          dk = kq(i, 5)
          If Not dic.exists(dk) Then
             c = c + 1
             kq(i, 3) = c
             dic.Add dk, c
          Else
             kq(i, 3) = dic.Item(dk)
          End If
          dk = kq(i, 6)
          If Not dic.exists(dk) Then
             d = d + 1
             kq(i, 4) = d
             dic.Add dk, d
          Else
             kq(i, 4) = dic.Item(dk)
          End If
      Next i
      lr = .Range("J" & Rows.Count).End(xlUp).Row
      If lr > 1 Then .Range("J2:M" & lr).ClearContents
      .Range("J2:M2").Resize(m).Value = kq
  End With
  Set oSList = Nothing
  Set dic = Nothing
 
End Sub

 

[bap226]

Em cảm ơn. 2 code đều chạy như mong đợi.