VBA登分 花名册汇总

laoau138

VBA登分 花名册汇总

grf1973

1. Sub mysub()
   
2.   Dim start As Double
   
3.   start = Timer
   
4.   
   
5.     '在这里添加你的代码
   
6. Dim arr(1 To 1000, 1 To 6)
   
7. For Each sh In Worksheets
   
8.     If sh.Index > 1 Then
   
9.         brr = sh.Range("a3:l" & sh.[a65536].End(3).Row)
   
10.         For i = 1 To UBound(brr)
    
11.             n = n + 1
    
12.             arr(n, 1) = brr(i, 2)
    
13.             arr(n, 2) = brr(i, 3)
    
14.             arr(n, 3) = brr(i, 5)
    
15.             arr(n, 4) = brr(i, 12)
    
16.             arr(n, 5) = brr(i, 11)
    
17.         Next
    
18.     End If
    
19. Next
    
20. [b3:f1000].ClearContents
    
21. [b3].Resize(n, 5) = arr
    
22.   
    
23.   MsgBox "程序共执行了" & Timer - start & "秒!"
    
24. End Sub
    

复制代码

laoau138

grf1973 发表于 2017-1-28 11:04

这个有人做了

laoau138

好多人做过这条    发答案学其他学习


yayahzmeng



Sub mysub()
  Dim start As Double
  start = Timer
  
    '在这里添加你的代码
    Application.ScreenUpdating = False
    Dim  arr, i%, j%, sname
    Dim sh As Worksheet, maxr
    sname = ActiveSheet.Name
    Range("B3:F" & [B65536].End(4).Row).ClearContents
    j = 3
    For Each sh In Sheets
        If sh.Name <> sname Then
            maxr = sh.[B65536].End(3).Row
            arr = sh.Range("B3:L" & maxr)
            For i = 1 To maxr - 2
                Sheets(sname).Cells(j, 2) = arr(i, 1)
                Sheets(sname).Cells(j, 3) = arr(i, 2)
                Sheets(sname).Cells(j, 4) = arr(i, 5)
                Sheets(sname).Cells(j, 5) = arr(i, 11)
                Sheets(sname).Cells(j, 6) = arr(i, 10)
                j = j + 1
            Next
            Erase arr
        End If
    Next
  Application.ScreenUpdating = True
  MsgBox "程序共执行了" & Format(Timer - start, "0.000") & "秒!"
End Sub





yayahzmeng

Sub mysub()
  Dim start As Double
  start = Timer
  
    '在这里添加你的代码
    Application.ScreenUpdating = False
    Dim i%, j%, z%, k%, maxr%, sname$, T$
    Dim sh As Worksheet
    sname = ActiveSheet.Name
    Range("B3:F" & [B65536].End(4).Row).ClearContents
    j = 3
    For Each sh In Sheets
        If sh.Name <> sname Then
            maxr = sh.[B65536].End(3).Row
            For i = 3 To maxr
                For z = 2 To 6
                    T = Sheets(sname).Cells(2, z)
                    k = sh.Range("B2:L2").Find(T).Column
                    Cells(j, z) = sh.Cells(i, k)
                Next
                j = j + 1
            Next
        End If
    Next
  Application.ScreenUpdating = True
  MsgBox "程序共执行了" & Format(Timer - start, "0.000") & "秒!"
End Sub