|
|
Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ReDim arr(1 To Sheets.Count)
With Sheets("考场汇总")
r = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(1, Columns.Count).End(xlToLeft).Column
If r < 2 Or y < 4 Then MsgBox "考场汇总为空！": End
.Range(.Cells(2, 4), .Cells(r, y)) = Empty
ar = .Range(.Cells(1, 1), .Cells(r, y))
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) <> "" Then
d(Trim(ar(i, 1))) = i
End If
Next i
For j = 4 To UBound(ar, 2) Step 2
If Trim(ar(1, j)) <> "" Then
zf = Left(Trim(ar(1, j)), 2)
d(zf) = j
End If
Next j
For Each sht In Worksheets
If sht.Name <> "考场汇总" Then
rs = sht.Cells(Rows.Count, 1).End(xlUp).Row
br = sht.Range("a2:h" & rs)
lh = d(sht.Name)
For i = 2 To UBound(br)
xh = d(Trim(br(i, 1)))
If xh <> "" And lh <> "" Then
ar(xh, lh) = br(i, 6)
ar(xh, lh + 1) = br(i, 7)
End If
Next i
End If
Next sht
.Range(.Cells(1, 1), .Cells(r, y)) = ar
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-1-17 08:23
楼主