|
Option Explicit
Sub test()
Dim i As Long, j As Long, k As Long, m As Long, arr, tt As String
With Sheets("数据源")
arr = .Range("a1:bg" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
End With
ReDim t(1 To UBound(arr, 2)) As String
m = 2
For i = 2 To UBound(arr, 1) - 1
For j = i To UBound(arr, 1) - 1
For k = 2 To UBound(arr, 2)
tt = Trim(arr(j, k))
If Len(tt) Then t(k) = t(k) & "-" & tt
Next
If arr(j, 1) <> arr(j + 1, 1) Then
arr(m, 1) = arr(i, 1)
For k = 2 To UBound(arr, 2)
If Len(t(k)) Then arr(m, k) = Mid(t(k), 2)
Next
ReDim t(1 To UBound(arr, 2)) As String
m = m + 1: i = j: Exit For
End If
Next j, i
With Sheets("2").[a1]
.CurrentRegion.ClearContents
.Resize(m - 1, UBound(arr, 2)) = arr
End With
End Sub |
|