[已解决]如何合并同一文件夹下的工作簿和工作表中的表格？

FIFAWORLDCUP

如何合并同一文件夹下的所有工作簿和工作表中的表格？

如何使代码遍历文件夹中的所有工作簿和所有工作簿中的所有工作表，使他们合并到一个工作表中？

代码如何写？谢谢！


abc.rar (12.35 KB, 下载次数: 16)

2016-11-18 14:19 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

su45

2016-11-18 14:47

就是扫读一个工作簿中的所有工作表，对吗？
但你的附件太简单了，红字是我改的：

        Do While objFile <> ""
            If objFile <> strThisName Then
                Set objExcel = Workbooks.Open(strThisPath & objFile)
                For Each sh In objExcel.Sheets
                    cfg_1 = sh.[a1].CurrentRegion
                    
                    For i = 1 To UBound(cfg_1)
                        If cfg_1(i, 1) = "序号" Then
                            KeyRows = i
                            Exit For
                        End If
                    Next i
                    
                    For i = 1 To UBound(cfg_1, 2)
                        isFind = False
                        For ia = 1 To UBound(cfg_0, 2)
                            If Len(cfg_0(1, ia)) = 0 Then Exit For
                            If cfg_1(KeyRows, i) = cfg_0(1, ia) Then
                                isFind = True
                                Exit For
                            End If
                        Next ia
                        If isFind = False Then
                            cfg_0(1, Cns_0) = cfg_1(KeyRows, i)
                            Cns_0 = Cns_0 + 1
                        End If
                    Next i
                    
                    For ia = KeyRows + 1 To UBound(cfg_1)
                        For ib = 1 To iMaxCount_0
                            For ic = 1 To UBound(cfg_1, 2)
                                If cfg_0(1, ib) = cfg_1(KeyRows, ic) Then
                                    cfg_0(Rows_0, ib) = cfg_1(ia, ic)
                                    Exit For
                                End If
                            Next ic
                        Next ib
                        Rows_0 = Rows_0 + 1
                    Next ia
                Next
                objExcel.Close True
            End If
            objFile = Dir
        Loop

跳转到最佳答案楼层

FIFAWORLDCUP

1.     Sub GetDatas()
   
2.       
   
3.         Dim strThisPath As String
   
4.         Dim strThisName As String
   
5.       
   
6.         Dim iMaxCount_0 As Long
   
7.         Dim Rows_0      As Long
   
8.         Dim Cns_0       As Long
   
9.         Dim KeyRows     As Long
   
10.         Dim i As Long, ia As Long, ib As Long, ic As Long
    
11.       
    
12.         Dim cfg_0       As Variant
    
13.         Dim cfg_1       As Variant
    
14.         Dim cfgRange_0  As Variant
    
15.       
    
16.         Dim isFind      As Boolean
    
17.       
    
18.         Dim objFile
    
19.         Dim objExcel
    
20.       
    
21.         strThisPath = ThisWorkbook.Path & ""
    
22.         strThisName = ThisWorkbook.Name
    
23.         objFile = Dir(strThisPath & "*.xlsx")
    
24. 
    
25.         Rows_0 = 2
    
26.         Cns_0 = 1
    
27.         iMaxCount_0 = 100       '汇总表最大标题数量，当需求超出可自行调整，影响运行效率，值越大，运行会越慢
    
28.         Set cfgRange_0 = Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(65536, iMaxCount_0))
    
29.         cfgRange_0.ClearContents
    
30.         cfg_0 = cfgRange_0.Value
    
31.       
    
32.         Do While objFile <> ""
    
33.             If objFile <> strThisName Then
    
34.                 Set objExcel = Workbooks.Open(strThisPath & objFile)
    
35.                 cfg_1 = objExcel.Sheets(1).[a1].CurrentRegion
    
36.                
    
37.                 For i = 1 To UBound(cfg_1)
    
38.                     If cfg_1(i, 1) = "序号" Then
    
39.                         KeyRows = i
    
40.                         Exit For
    
41.                     End If
    
42.                 Next i
    
43.                
    
44.                 For i = 1 To UBound(cfg_1, 2)
    
45.                     isFind = False
    
46.                     For ia = 1 To UBound(cfg_0, 2)
    
47.                         If Len(cfg_0(1, ia)) = 0 Then Exit For
    
48.                         If cfg_1(KeyRows, i) = cfg_0(1, ia) Then
    
49.                             isFind = True
    
50.                             Exit For
    
51.                         End If
    
52.                     Next ia
    
53.                     If isFind = False Then
    
54.                         cfg_0(1, Cns_0) = cfg_1(KeyRows, i)
    
55.                         Cns_0 = Cns_0 + 1
    
56.                     End If
    
57.                 Next i
    
58.                
    
59.                 For ia = KeyRows + 1 To UBound(cfg_1)
    
60.                     For ib = 1 To iMaxCount_0
    
61.                         For ic = 1 To UBound(cfg_1, 2)
    
62.                             If cfg_0(1, ib) = cfg_1(KeyRows, ic) Then
    
63.                                 cfg_0(Rows_0, ib) = cfg_1(ia, ic)
    
64.                                 Exit For
    
65.                             End If
    
66.                         Next ic
    
67.                     Next ib
    
68.                     Rows_0 = Rows_0 + 1
    
69.                 Next ia
    
70.                 objExcel.Close True
    
71.             End If
    
72.             objFile = Dir
    
73.         Loop
    
74.       
    
75.         cfgRange_0.Value = cfg_0
    
76.     End Sub
    

复制代码

这个代码只能合并同一文件夹中的工作簿，不能扫描工作簿中的每一个工作表，代码要如何改写？谢谢！

su45

就是扫读一个工作簿中的所有工作表，对吗？
但你的附件太简单了，红字是我改的：

        Do While objFile <> ""
            If objFile <> strThisName Then
                Set objExcel = Workbooks.Open(strThisPath & objFile)
                For Each sh In objExcel.Sheets
                    cfg_1 = sh.[a1].CurrentRegion
                    
                    For i = 1 To UBound(cfg_1)
                        If cfg_1(i, 1) = "序号" Then
                            KeyRows = i
                            Exit For
                        End If
                    Next i
                    
                    For i = 1 To UBound(cfg_1, 2)
                        isFind = False
                        For ia = 1 To UBound(cfg_0, 2)
                            If Len(cfg_0(1, ia)) = 0 Then Exit For
                            If cfg_1(KeyRows, i) = cfg_0(1, ia) Then
                                isFind = True
                                Exit For
                            End If
                        Next ia
                        If isFind = False Then
                            cfg_0(1, Cns_0) = cfg_1(KeyRows, i)
                            Cns_0 = Cns_0 + 1
                        End If
                    Next i
                    
                    For ia = KeyRows + 1 To UBound(cfg_1)
                        For ib = 1 To iMaxCount_0
                            For ic = 1 To UBound(cfg_1, 2)
                                If cfg_0(1, ib) = cfg_1(KeyRows, ic) Then
                                    cfg_0(Rows_0, ib) = cfg_1(ia, ic)
                                    Exit For
                                End If
                            Next ic
                        Next ib
                        Rows_0 = Rows_0 + 1
                    Next ia
                Next
                objExcel.Close True
            End If
            objFile = Dir
        Loop

su45

解决了吗？解决了就设置为最佳

FIFAWORLDCUP

su45 发表于 2016-11-18 16:04
解决了吗？解决了就设置为最佳

谢谢高手！