|
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("sheet1")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a3:d" & r)
- m = 0
- For i = 1 To UBound(arr)
- If Not d.exists(arr(i, 3)) Then
- m = m + 1
- ReDim brr(1 To 4)
- brr(1) = m
- brr(2) = arr(i, 2)
- brr(3) = arr(i, 3)
- Set brr(4) = CreateObject("scripting.dictionary")
- Else
- brr = d(arr(i, 3))
- End If
- brr(4)(arr(i, 4)) = ""
- d(arr(i, 3)) = brr
- Next
- End With
- For Each aa In d.keys
- m = m + 1
- brr = d(aa)
- ss = ""
- kk = brr(4).keys
- ReDim drr(1 To 2)
- drr(1) = kk(0)
- drr(2) = kk(0)
- For j = 1 To UBound(kk)
- If drr(2) + 1 = kk(j) Then
- drr(2) = kk(j)
- Else
- If drr(1) = drr(2) Then
- ss = ss & "," & Format(drr(1), "m月d日")
- Else
- ss = ss & "," & Format(drr(1), "m月d日") & "-" & Format(drr(2), "d日")
- End If
- drr(1) = kk(j)
- drr(2) = kk(j)
- End If
- Next
- If drr(1) = drr(2) Then
- ss = ss & "," & Format(drr(1), "m月d日")
- Else
- ss = ss & "," & Format(drr(1), "m月d日") & "-" & Format(drr(2), "d日")
- End If
- brr(4) = Mid(ss, 2)
- d(aa) = brr
- Next
- With Worksheets("sheet2")
- .UsedRange.Offset(2, 0).Clear
- .Range("a3").Resize(d.Count, 4) = Application.Transpose(Application.Transpose(d.items))
- End With
- End Sub
复制代码 |
|