|
|
Option Explicit
Sub TEST()
Dim ar, vResult, i&, j&, y&, x&, dic As Object, vKey
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
For i = 0 To 1
Set dic(i) = CreateObject("Scripting.Dictionary")
Next i
ar = Range("AA2", Cells(Rows.Count, "AF").End(3))
For i = 1 To UBound(ar): dic(0)(ar(i, 1)) = "": Next
For i = 1 To UBound(ar)
vKey = ar(i, 2) & "|" & ar(i, 1)
dic(1)(vKey) = Array(ar(i, 4), ar(i, 6))
Next i
ReDim vResult(1 To dic(0).Count + 1, 1 To dic(0).Count * 2 + 1)
y = 1
For Each vKey In dic(0).keys
y = y + 1
vResult(y, 1) = vKey
x = x + 1
vResult(1, x * 2) = vKey
Next
For i = 2 To UBound(vResult)
For j = 2 To UBound(vResult, 2) Step 2
vKey = vResult(i, 1) & "|" & vResult(1, j)
If dic(1).exists(vKey) Then
vResult(i, j) = dic(1)(vKey)(0)
vResult(i, j + 1) = dic(1)(vKey)(1)
End If
Next j
Next i
With [Al1].Resize(UBound(vResult), UBound(vResult, 2))
.Value = vResult
For i = 2 To UBound(vResult, 2) Step 2
.Cells(1, i).Resize(, 2).Merge
Next i
.HorizontalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.Columns(1).Font.Bold = True
.Rows(1).Font.Bold = True
.EntireColumn.AutoFit
.EntireRow.AutoFit
End With
Set dic = Nothing
Application.ScreenUpdating = True
Beep
End Sub |
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-2-18 13:36
楼主