工作薄合并

microyip

小花鹿 发表于 2016-11-14 09:40
多工作薄多工作表，而且结构还不一样，很麻烦的...................................................... ...

总的来说，如果根据我提供的通用方案，基本可以解决，只是楼主就是伸手党忠诚党员，重点是楼主连需求都不说，然后你就实现给我吧

小花鹿

janemark 发表于 2016-11-14 09:43
其实您只要把所有的工作薄合并到一个工作薄中即可，这个应该不难的吧。

难倒是不很难，就是写代码麻烦.......................................................................................

jsgj2023

1. Sub 多簿合并() 'fhxy
   
2.         Dim arr, brr(1 To 2000, 1 To 25)
   
3.         Dim n&, x&, y&, k&, myName$, myPath$
   
4.         Dim Sh As Worksheet, m%
   
5.         t = Timer
   
6.         Application.ScreenUpdating = False
   
7.         m = 0
   
8.          For Each Sh In Sheets
   
9.                 If Sh.Name = "合并结果" Then MsgBox "合并结果存在!": m = m + 1
   
10.         Next
    
11.         If m = 0 Then
    
12.                 ActiveSheet.Name = "合并结果"
    
13.                 Cells.ClearContents
    
14.                 With Application.FileDialog(msoFileDialogFolderPicker)
    
15.                         If .Show = False Then Exit Sub
    
16.                         myPath = .SelectedItems(1) & ""
    
17.                 End With
    
18.                 'myPath = ThisWorkbook.Path & "" & "分表" & ""
    
19.                 myName = Dir(myPath & "*.xls")
    
20.                 Do While myName <> "" And myName <> "合并结果"
    
21.                         With GetObject(myPath & myName)
    
22.                                 n = n + 1
    
23.                                 arr = .Sheets(1).Range("a1").CurrentRegion
    
24.                                 If n = 1 Then
    
25.                                         For x = 1 To UBound(arr)
    
26.                                                 k = k + 1
    
27.                                                 For y = 1 To UBound(arr, 2)
    
28.                                                         brr(k, y) = arr(x, y)
    
29.                                                 Next y
    
30.                                         Next x
    
31.                                         .Close False
    
32.                                 Else
    
33.                                         For x = 3 To UBound(arr)
    
34.                                                 k = k + 1
    
35.                                                 For y = 1 To UBound(arr, 2)
    
36.                                                         brr(k, y) = arr(x, y)
    
37.                                                 Next y
    
38.                                         Next x
    
39.                                         .Close False
    
40.                                 End If
    
41.                         End With
    
42.                         myName = Dir
    
43.                 Loop
    
44.                 Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
45.                 With Cells
    
46.                         .EntireColumn.AutoFit
    
47.                         .Font.Size = 9
    
48.                         .HorizontalAlignment = xlCenter
    
49.                         .VerticalAlignment = xlCenter
    
50.                 End With
    
51.                 If Application.CountA(Rows(2)) < 1 Then Rows(2).Delete
    
52.         End If
    
53.         Application.ScreenUpdating = True
    
54.         MsgBox Timer - t
    
55. End Sub

复制代码

jsgj2023

jsgj2023 发表于 2016-11-14 14:38

如只想简单的合并，这段代码给你参考，但是我发现你各表的结构其实是有差异的。