请问怎么快速汇总花名册

Pro_mise

各位达人，小弟愚昧 ，在此向各位请教：公司给每个员工下发了一个表格（模板一样），主要就是填写各位员工的基本信息，然后每个员工填写完整后提交到我处，现在我就需要把员工提交过来的N个表汇总到一个总表里面，因为人数众多~~如果一个表一个表的复制粘贴也能完成任务，就是花的时间多，有无什么捷径可以提高效率达到目的呢，请各位指教。我附件里面有简单的表格。

ZDYCTD

我记得论坛上有很多这方面的贴子,搜索一下.

君妍

吼吼，真的是很巧哈，我觉得我们说不定是一个单位的呢，呵呵，猜测，不过或许我能提供一点帮助，之前我也遇到过一个大约的问题，然后我就上网搜索了一下，找了一个还算是比较好用的宏公式，我发给你，你找写的那个内容试一下。
备注：这段程序我用过了，基本能实现需要，只是每个合并过去的表格的表头也一同复制进去了，稍微有些瑕疵，不过这个相当省事，能极大的提高工作效率，省去了不停的复制 粘贴。

新建一个工作表，命名后保存到和欲合并的几个文件同一个文件文件夹，摁 alt + f11,双击工程资源管理器里面的sheet1(sheet1),在右侧的代码区粘贴如下代码。运行。等候一会就OK了。

Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
If Num = 1 Then
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
Else
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Offset(1, 0).Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
End If
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

ykcbf1100

VBA，多文件单表简单合并

ykcbf1100

1. Sub ykcbf()         '//2025.3.27
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Dim arr, brr(1 To 10000, 1 To 100)
   
6.     p = ThisWorkbook.Path & ""
   
7.     Set sh = Sheets("Sheet1")
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If LCase$(f.Name) Like "*.xls*" Then
   
10.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
11.                 Set wb = Workbooks.Open(f, 0)
    
12.                 arr = wb.Sheets(1).UsedRange
    
13.                 wb.Close False
    
14.                 For i = 2 To UBound(arr)
    
15.                     If arr(i, 1) <> Empty Then
    
16.                         m = m + 1
    
17.                         For j = 1 To UBound(arr, 2)
    
18.                             brr(m, j) = arr(i, j)
    
19.                         Next
    
20.                     End If
    
21.                 Next
    
22.             End If
    
23.         End If
    
24.     Next
    
25.     With sh
    
26.         .[a1].CurrentRegion.Offset(1).ClearContents
    
27.         .[a2].Resize(m, UBound(arr, 2)) = brr
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    
31. 
    

复制代码

mjm04

函数 么是体力活，用PQ吧

或是找人写 VBA 吧

wyslw2004

不是wps的话，用PQ，来自文件夹，，点几下鼠标就行了