遍历文件夹，提取工作薄内指定内容到工作总表

取经人

有很多个工作薄，工作薄是两种格式，一种XLS 一种xlsx，提取里面的  姓名  毕业或就读学校  联系方式 到总表
如图


以下为样例附件 excel分表到excel总表.zip (64.17 KB, 下载次数: 32)

2021-8-9 13:08 上传

点击文件名下载附件

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim d As Object
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
ReDim arr(1 To 2000, 1 To 15)
f = Dir(ThisWorkbook.Path & "\*.xls*")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
        n = n + 1
        ar = wb.Worksheets(1).Range("a1:f38")
        wb.Close False
        arr(n, 1) = n
        arr(n, 2) = ar(2, 2)
        arr(n, 4) = ar(2, 4)
        arr(n, 5) = ar(7, 4)
        arr(n, 6) = ar(4, 4)
        arr(n, 7) = ar(4, 2)
        arr(n, 8) = ar(5, 2)
        arr(n, 9) = ar(6, 2)
        arr(n, 10) = ar(5, 4)
        arr(n, 11) = ar(10, 2)
        arr(n, 13) = ar(7, 6)
    End If
f = Dir
Loop
With Sheet1
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r > 3 Then .Range("a4:o" & r) = Empty
    .Cells(4, 1).Resize(n, UBound(arr, 2)) = arr
End With
MsgBox "ok!"
Application.ScreenUpdating = True
        
End Sub

3190496160

excel分表到excel总表.rar (70.08 KB, 下载次数: 49)

2021-8-9 14:27 上传

点击文件名下载附件

3190496160

代码仅供参考，一是有些项目在分表中找不到，二是，分表有些单元格数据的呈现方式不好处理，

xrs08234

Sub 提取()
Dim PathName$, sr$, n%, i%, y%, ARR, ARR1
Application.ScreenUpdating = False
ARR = Sheet1.UsedRange
PathName = ThisWorkbook.Path & "\*.*"
sr = Dir(PathName)
n = Range("M65536").End(xlUp).Row
y = 0
Do While sr <> ""
    If sr <> ActiveWorkbook.Name Then
      For i = 4 To UBound(ARR)
        If Split(sr, ".")(0) = ARR(i, 2) Then
           y = 1
        End If
      Next i
        If y = 0 Then
            n = n + 1
            Set App = Application
            Set SourceBook = App.Workbooks.Open(ThisWorkbook.Path & "\" & sr, 0, True)
            Set Sourcesheet = SourceBook.Worksheets(1)
            With Sourcesheet
                ARR1 = .Range(.Range("A2"), .Range("F7"))
            End With
            SourceBook.Close False
            Cells(n, 2) = ARR1(1, 2)
            Cells(n, 6) = ARR1(3, 4)
            Cells(n, 13) = ARR1(6, 6)
           Erase ARR1
        End If
       y = 0
    End If
  sr = Dir
Loop
Application.ScreenUpdating = True
End Sub

取经人

xrs08234 发表于 2021-8-9 15:21
Sub 提取()
Dim PathName$, sr$, n%, i%, y%, ARR, ARR1
Application.ScreenUpdating = False

感谢帮助，

取经人

3190496160 发表于 2021-8-9 14:27

十分感谢，完美解决

ykcbf1100

参与一下，练个手

ykcbf1100

纯练手。。。

1. Sub ykcbf()  '//2024.2.3
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     b = [{"B2","D4","F7";2,6,13}]
   
7.     ReDim brr(1 To 1000, 1 To 15)
   
8.     For Each f In Fso.GetFolder(p).Files
   
9.         If f.Name Like "*.xls*" Then
   
10.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
11.                 fn = Fso.GetBaseName(f)
    
12.                 Set wb = Workbooks.Open(f, 0)
    
13.                 m = m + 1
    
14.                 brr(m, 1) = m
    
15.                 With wb.Sheets(1)
    
16.                     For x = 1 To 3
    
17.                         brr(m, b(2, x)) = .Range(b(1, x))
    
18.                     Next
    
19.                     wb.Close False
    
20.                 End With
    
21.             End If
    
22.         End If
    
23.     Next f
    
24.     With sh
    
25.         .UsedRange.Offset(3) = ""
    
26.         .[a4].Resize(m, UBound(brr, 2)) = brr
    
27.     End With
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码