Option Explicit
Sub test()
Dim arr, i, j, k, cnt, a, b, t
arr = Range("g4:l" & [d4].End(xlDown).Row)
ReDim brr(1 To UBound(arr, 1), 1 To 1)
For i = 1 To UBound(arr, 1)
ReDim mark(1 To 2, 1 To UBound(arr, 2))
cnt = 0
For j = 1 To UBound(arr, 2)
If Len(arr(i, j)) Then
For k = 1 To Len(arr(i, j))
If Not IsNumeric(Mid(arr(i, j), k, 1)) Then
a = Val(Left(arr(i, j), k - 1))
b = Mid(arr(i, j), k)
Exit For
End If
Next
For k = 1 To cnt
If mark(2, k) = b Then
mark(1, k) = mark(1, k) + a
Exit For
End If
Next
If k = cnt + 1 Then
cnt = cnt + 1
mark(1, k) = a: mark(2, k) = b
End If
End If
Next
If cnt > 0 Then
For j = 1 To cnt
t = t & "," & mark(1, j) & mark(2, j)
Next
brr(i, 1) = Mid(t, 2): t = vbNullString
End If
Next
[m4].Resize(UBound(brr, 1)) = brr
End Sub |