|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Option Explicit
Sub test1()
Dim ar, br(), strResult$(), i&, j&, k&, m&, n&, p&, r&
Application.ScreenUpdating = False
ReDim strResult(1 To 10 ^ 4, 1 To 6)
With Worksheets(2).[A1].CurrentRegion
p = 2
ar = .Resize(.Rows.Count + 1)
For i = 2 To UBound(ar) - 1
If ar(i + 1, 1) <> ar(p, 1) Then
r = r + 1
ReDim Preserve br(1 To r)
br(r) = Range(.Cells(p, 1), .Cells(i, 1)).Resize(, 6).Value '.Interior.ColorIndex = n
For k = 1 To UBound(br(r))
For j = 2 To 3
br(r)(k, j + 3) = br(r)(k, j)
Next j
Next k
p = i + 1
End If
Next i
End With
r = 0
ar = Worksheets(1).[A1].CurrentRegion.Value
For i = 1 To UBound(ar)
For j = 1 To UBound(br)
If br(j)(1, 1) = ar(i, 1) Then
For m = 1 To UBound(br(j))
r = r + 1
For n = 1 To UBound(br(j), 2)
strResult(r, n) = br(j)(m, n)
Next n
For n = 2 To 4
strResult(r, n) = ar(i, n)
Next n
Next m
End If
Next j
Next i
With Worksheets(3)
.[A1].CurrentRegion.Offset(1).Clear
.[A2].Resize(r, UBound(strResult, 2)) = strResult
.Activate
End With
Application.ScreenUpdating = True
Beep
End Sub
|
|