数据合并

jx928867128

数据合并.rar (35.21 KB, 下载次数: 13)

2024-7-30 08:39 上传

点击文件名下载附件

"数据合并说明：
一、数据源说明
1、数据源与合并后的文件在同一文件夹。
二、程序要求说明：
1、点导入后自动清除汇总表中第2行下面所有的内容（第1行和第二行中内容不能删除）。
2、将数据源中的数据进行合并后从汇总表中的第三行开始填写（不能改变数据源中的数据格式）。
3、数源中的工作表增加或减少后程序也能正确合并。"                                                       
                                                       
                                                       
                                                       
                                                       
                                                       
                                                       
                                                       
                                                       
                                                       
                                                       
                                                       

蓝桥玄霜

合并的例子：

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.7.30
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     sh.[a3].Resize(1000, 100).ClearContents
   
6.     p = ThisWorkbook.Path & ""
   
7.     ReDim brr(1 To 10000, 1 To 100)
   
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.                 fn = fso.GetBaseName(f)
    
12.                 Set wb = Workbooks.Open(f, 0)
    
13.                 n = n + 1
    
14.                 With wb.Sheets(1)
    
15.                     arr = .UsedRange
    
16.                     If n = 1 Then
    
17.                         r1 = .Cells(Rows.Count, 2).End(3).Row
    
18.                         .Rows(4 & ":" & r1).Copy sh.[a3]
    
19.                     Else
    
20.                         For i = 6 To UBound(arr)
    
21.                             If arr(i, 2) <> Empty Then
    
22.                                 m = m + 1
    
23.                                 For j = 1 To UBound(arr, 2)
    
24.                                     brr(m, j) = arr(i, j)
    
25.                                 Next
    
26.                             End If
    
27.                         Next
    
28.                     End If
    
29.                 End With
    
30.                 wb.Close 0
    
31.             End If
    
32.         End If
    
33.     Next f
    
34.     With sh
    
35.         .Cells(r1, 1).Resize(m, UBound(arr, 2)) = brr
    
36.         r = .Cells(Rows.Count, 1).End(3).Row
    
37.         .Rows("6:6").Copy
    
38.         .Rows("7:" & r).PasteSpecial Paste:=xlPasteFormats
    
39.         Application.CutCopyMode = False
    
40.         .[a5].Resize(r - 4, UBound(arr, 2)).Sort .[a5], 1
    
41.         .[i2].Select
    
42.     End With
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "OK！"
    
45. End Sub
    
46. 
    

复制代码

jx928867128

ykcbf1100 发表于 2024-7-30 11:30
附件供参考。。。

万分感谢老师的再次帮忙，再次谢谢您