合并多个xls文件的数据

279517904

有以上这些文件，实际比如3月31天，有01-31的ABD文件，以日期+字母为命名。
其中一个文件内容，人员数量不一：

在汇总.xls中达到以下效果：

附件：
示例.zip (42.13 KB, 下载次数: 6)

2024-5-20 12:02 上传

点击文件名下载附件

发哥76

Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim Arr, Brr(), Mpath$, Mfile$, i%, n%
    Mpath = ThisWorkbook.Path & "\"
    Mfile = Dir(Mpath & "*.xls")
    Do
        If Mfile <> ThisWorkbook.Name Then
            Set wb = GetObject(Mpath & Mfile)
            Arr = wb.Sheets(1).[a1].CurrentRegion
            If UBound(Arr) >= 2 Then
                For i = 2 To UBound(Arr)
                    n = n + 1
                    ReDim Preserve Brr(1 To 3, 1 To n)
                        Brr(1, n) = Arr(i, 1)
                        Brr(2, n) = "'" & Mid(Mfile, 1, 2)
                        Brr(3, n) = Mid(Split(Mfile, ".xls")(0), 3)
                Next
            End If
            wb.Close False
        End If
        Mfile = Dir
    Loop Until Mfile = ""
    [a2].Resize(n, 3) = Application.Transpose(Brr)
    Erase Arr, Brr
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

LIUZHU

参与下，这个效果

LIUZHU

JSA代码，供参考

1. function 数据汇总(){
   
2.         Application.ScreenUpdating=false;
   
3.         let arr=[["姓名","日期","项目"]];
   
4.         let fname=Dir(`${ThisWorkbook.Path}\\*.xls*`,8);
   
5.         while(fname!=""){
   
6.                 if (fname!=ThisWorkbook.Name){
   
7.                         Workbooks.Open(`${ThisWorkbook.Path}\\${fname}`);
   
8.                         let [rq,xm]=fname.match(/\d+|[A-Z]+/g);
   
9.                         Range("a1").CurrentRegion.Value2.slice(1).forEach(([x])=>arr.push([x,rq,xm]));
   
10.                         ActiveWorkbook.Close(false);
    
11.                 }
    
12.                 fname=Dir();
    
13.         }
    
14.         Range("a1").Resize(arr.length,arr[0].length).Value2=arr;
    
15.         Application.ScreenUpdating=true;
    
16.         alert(`<h2 style="color:red">汇总完毕。<h2>`);
    
17. }

复制代码

LIUZHU

附件，需要用WPS测试

279517904

LIUZHU 发表于 2024-5-21 00:22
附件，需要用WPS测试

感谢帮助，试验了下，很成功。
，对我这小白来说，省了一万道工序，感谢感谢！

279517904

发哥76 发表于 2024-5-20 15:41
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

感谢帮助，试验了下，很成功。
对我这小白来说，省了一万道工序，
感谢感谢！