Nhờ giúp đỡ về gộp chuỗi mã hàng (2 người xem)

[VetMini]

Dữ liệu ít hay nhiều gì thì code trên cũng phải dựa vào điều kiện là dữ liệu đã được sắp xếp.
Thử thay đổi thứ tự dữ liệu trong file mẫu, chạy thì biết liền.

 

[concogia]

Đố các bạn nhậu của tui, với dữ liệu của bài #12 viết code với 1 vòng lặp ra kết quả
Nếu bạn nào viết được & nếu chủ nhật này tui bốc thăm mà trúng quà, tui sẽ....tặng quà lại cho bạn đó
Thân

 

[luanvnn]

Bạn thử cái sub này xem đúng không.

Sub gopdulieu()
    Dim arr, i As Long, s As String, kq, dic As Object, ngay As String, b As Long, T, k As Integer, s1 As String, s2 As String
    Dim a As Long, ten As String, j As Integer
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
         arr = .Range("B5:C58").Value
         ReDim kq(1 To UBound(arr), 1 To 2)
         For i = 1 To UBound(arr)
             ngay = arr(i, 2)
             If Not dic.exists(ngay) Then
                dic.Add ngay, "#" & arr(i, 1)
                a = a + 1
                kq(a, 1) = ngay
             Else
                s = dic.Item(ngay)
                s = s & "#" & arr(i, 1)
                dic.Item(ngay) = s
             End If
       Next i
       For i = 1 To a
           s = dic.Item(kq(i, 1))
           T = Split(s, "#")
           b = UBound(T)
         
           For k = 1 To b
             s1 = T(k)
             If InStr(1, s, s1) Then
                ten = ten & ";" & s1
                j = 0
                Do
                   j = j + 1
                   s2 = Left(s1, Len(s1) - 4) & (Right(s1, 4) + j)
                   If InStr(1, s, s2) Then
                      s = Replace(s, s2, "")
                   Else
                      s2 = Left(s1, Len(s1) - 4) & (Right(s1, 4) + j - 1)
                      If s1 <> s2 Then ten = ten & "-" & s2
                      Exit Do
                   End If
                Loop
             End If
          Next k
           kq(i, 2) = Right(ten, Len(ten) - 1)
           ten = Empty
       Next i
       .Range("F14:G14").Resize(a).Value = kq
   End With
End Sub

Mình có vấn đề cần giúp đỡ, nếu một số mã hàng chưa xuất được mình muốn thống kê riêng vào mục hàng tồn (File đính kèm). nhờ bạn sửa code giúp