|
|
Sub 转换()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With Sheets("基础数据")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "基础数据为空！": End
ar = .Range("a1:d" & r)
End With
For i = 2 To UBound(ar)
If Not d.exists(Trim(ar(i, 1))) Then
d(Trim(ar(i, 1))) = i
Else
d(Trim(ar(i, 1))) = d(Trim(ar(i, 1))) & "," & i
End If
Next i
ReDim br(1 To d.Count, 1 To 200)
For Each k In d.keys
n = n + 1
br(n, 1) = k
zd = d(k)
rr = Split(zd, ",")
lh = 1
For s = 0 To UBound(rr)
xh = rr(s)
lh = lh + 3
br(n, lh - 2) = ar(xh, 3)
br(n, lh - 1) = ar(xh, 2)
br(n, lh) = ar(xh, 4)
Next s
Next k
With Sheets("最终结果")
.[a1].CurrentRegion.Offset(1) = Empty
.[a2].Resize(n, UBound(br, 2)) = br
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-10-26 09:47
