历遍工作表汇总指定行到一个表中用的是多次嵌套有没有好的代码不用每天天就要续写代码

Hontyu

1. <div class="blockcode"><blockquote>Sub TEST()
   
2.     Dim ar, br, Sht, iR, iC, i, j
   
3.     Dim d: Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     With Sheet2.[D1].CurrentRegion
   
6.         .Offset(3, 2).ClearContents
   
7.         ar = .Value
   
8.     End With
   
9.     For i = 4 To UBound(ar): d(ar(i, 2)) = i: Next
   
10.     For j = 3 To UBound(ar, 2): d(ar(1, j)) = j: Next
    
11.     For Each Sht In Sheets
    
12.         With Sht
    
13.             If .Name <> "结果" Then
    
14.                 If Application.CountA(.UsedRange.Cells) = 0 Then
    
15.                     Exit For
    
16.                 End If
    
17.                 br = .UsedRange
    
18.                 For i = 2 To UBound(br)
    
19.                     If d.Exists(br(i, 2)) Then
    
20.                         iR = d(br(i, 2))
    
21.                         If d.Exists(Val(.Name)) Then
    
22.                             iC = d(Val(.Name))
    
23.                             ar(iR, iC) = Val(br(i, 11))
    
24.                         End If
    
25.                     End If
    
26.                 Next i
    
27.             End If
    
28.         End With
    
29.     Next Sht
    
30.     Sheet2.[D1].Resize(UBound(ar), UBound(ar, 2)) = ar
    
31.     Set d = Nothing
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK!"
    
34. End Sub

复制代码