|
-
- Sub 汇总学生信息()
- Dim wb1 As Workbook
- Dim wb2 As Workbook
- Dim ws1 As Worksheet
- Dim ws2 As Worksheet
- Dim rng As Range
- Dim rngs As Range
- Dim mypath$, myname$, i%
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- mypath = ThisWorkbook.Path & ""
- myname = Dir(mypath & "*周岁人口册.xls")
-
- Do While myname <> ""
- If myname <> ThisWorkbook.Name Then
- Set wb = GetObject(mypath & myname)
- With wb
- For Each ws In .Worksheets
- If ws.Name Like "*岁" Then
- With ws
- r = .Cells(.Rows.Count, 2).End(xlUp).Row
- If r > 6 Then
- arr = .Range("a7:ac" & r)
- For i = 1 To UBound(arr)
- If Not d.exists(ws.Name) Then
- m = 1
- ReDim brr(1 To UBound(arr, 2), 1 To m)
- Else
- brr = d(ws.Name)
- m = UBound(brr, 2) + 1
- ReDim Preserve brr(1 To UBound(arr, 2), 1 To m)
- End If
- For j = 1 To UBound(arr, 2)
- brr(j, m) = arr(i, j)
- Next
- d(ws.Name) = brr
- Next
- End If
- End With
- End If
- Next
- .Close False
- End With
- End If
- myname = Dir
- Loop
- With ThisWorkbook
- For Each aa In d.keys
- arr = d(aa)
- ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr))
- For i = 1 To UBound(arr)
- For j = 1 To UBound(arr, 2)
- brr(j, i) = arr(i, j)
- Next
- Next
- On Error Resume Next
- Set ws = .Worksheets(aa)
- If Err Then
- Set ws = .Worksheets.Add(after:=Worksheets(Worksheets.Count))
- ws.Name = aa
- End If
- On Error GoTo 0
- With .Worksheets(aa)
- .UsedRange.Offset(6, 0).ClearContents
- .Range("a7").Resize(UBound(brr), UBound(brr, 2)) = brr
- End With
- Next
- End With
- End Sub
复制代码 |
|