|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
原始表到目标表1和目标表2的代码。
- Sub test1()
- Dim r%, i%, m%, k%
- Dim arr, brr, zrr()
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- With Worksheets("原始表")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:c" & r)
- End With
- For i = 1 To UBound(arr)
- If Not d.exists(arr(i, 2)) Then
- m = 1
- ReDim brr(1 To m)
- Else
- brr = d(arr(i, 2))
- m = UBound(brr) + 1
- ReDim Preserve brr(1 To m)
- End If
- brr(m) = arr(i, 1)
- d(arr(i, 2)) = brr
- Next
- For Each aa In d.keys
- brr = d(aa)
- For i = 1 To UBound(brr) - 1
- p = i
- For j = i + 1 To UBound(brr)
- If Val(brr(p)) > Val(brr(j)) Then
- p = j
- End If
- Next
- If p <> i Then
- temp = brr(i)
- brr(i) = brr(p)
- brr(p) = temp
- End If
- Next
- d(aa) = brr
- Next
- ReDim crr(1 To d.Count, 1 To 2)
- ReDim drr(1 To UBound(arr), 1 To 2)
- m = 0
- n = 0
- For Each aa In d.keys
- m = m + 1
- crr(m, 1) = aa
- brr = d(aa)
- xm = -1
- k = 0
- For i = 1 To UBound(brr)
- If Val(brr(i)) <> Val(xm) + 1 Then
- k = k + 1
- ReDim Preserve zrr(1 To k)
- zrr(k) = Array(i, i)
- Else
- If k > 0 Then
- zrr(k)(1) = i
- End If
- End If
- xm = brr(i)
- Next
- For k = 1 To UBound(zrr)
- n = n + 1
- drr(n, 1) = aa
- If zrr(k)(0) = zrr(k)(1) Then
- crr(m, 2) = crr(m, 2) & "," & brr(zrr(k)(0))
- drr(n, 2) = brr(zrr(k)(0))
- Else
- crr(m, 2) = crr(m, 2) & "," & brr(zrr(k)(0)) & "-" & brr(zrr(k)(1))
- drr(n, 2) = brr(zrr(k)(0)) & "-" & brr(zrr(k)(1))
- End If
- Next
- Next
- For i = 1 To UBound(crr)
- If Len(crr(i, 2)) <> 0 Then
- crr(i, 2) = Mid(crr(i, 2), 2)
- End If
- Next
- With Worksheets("目标表1")
- .UsedRange.Offset(1, 0).Clear
- .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
- End With
- With Worksheets("目标表2")
- .UsedRange.Offset(1, 0).Clear
- .Range("a2").Resize(n, UBound(drr, 2)) = drr
- End With
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|