[已解决]如何利用vba讲同一个文件夹下的多个表格合并成一个表格

林龙成

请各位大神帮帮忙，我需要合并同一个文件夹下的多个表格，要以C列“名称”为提取条件，C列有数据的都需要提取到同一个表格中，下面是附件，希望大神们能帮帮忙！谢谢了！

最佳答案

月排行榜 / 总排行榜

冥王

2015-10-1 15:13

1. Sub shtHeBing()
   
2.     Dim strPath$, strFile$, i%, wb As Workbook
   
3.     strPath = ThisWorkbook.Path & ""
   
4.     strFile = Dir(strPath & "*.xls")
   
5.     Application.ScreenUpdating = False
   
6.     With ThisWorkbook.Sheets(1)
   
7.         .Cells.Clear
   
8.         Do While strFile <> ""
   
9.             If strFile = ThisWorkbook.Name Then GoTo 100
   
10.             i = i + 1
    
11.             Set wb = Workbooks.Open(strPath & strFile)
    
12.             If i = 1 Then
    
13.                 wb.Sheets(1).UsedRange.Copy .Range("A1")
    
14.             Else
    
15.                 wb.Sheets(1).UsedRange.Offset(1, 0).Copy .Cells(Rows.Count, "C").End(xlUp).Offset(1, -2)
    
16.             End If
    
17.             wb.Close False
    
18. 100:
    
19.             strFile = Dir
    
20.         Loop
    
21.         .Columns("A:F").AutoFit
    
22.         .UsedRange.EntireRow.AutoFit
    
23.     End With
    
24.     Application.ScreenUpdating = True
    
25. End Sub

复制代码

跳转到最佳答案楼层

qh8600

百度有很多例子

冥王

附件解压到你的文件所在的文件夹，点击按钮合并。不知道是不是你需要的

林龙成

冥王 发表于 2015-9-23 17:05
附件解压到你的文件所在的文件夹，点击按钮合并。不知道是不是你需要的

我点击了之后是这个样子的？是哪里出了问题啊，能不能帮我更改一下

冥王

1. Sub shtHeBing()
   
2.     Dim strPath$, strFile$, i%, wb As Workbook
   
3.     strPath = ThisWorkbook.Path & ""
   
4.     strFile = Dir(strPath & "*.xls")
   
5.     Application.ScreenUpdating = False
   
6.     With ThisWorkbook.Sheets(1)
   
7.         .Cells.Clear
   
8.         Do While strFile <> ""
   
9.             If strFile = ThisWorkbook.Name Then GoTo 100
   
10.             i = i + 1
    
11.             Set wb = Workbooks.Open(strPath & strFile)
    
12.             If i = 1 Then
    
13.                 wb.Sheets(1).UsedRange.Copy .Range("A1")
    
14.             Else
    
15.                 wb.Sheets(1).UsedRange.Offset(1, 0).Copy .Cells(Rows.Count, "C").End(xlUp).Offset(1, -2)
    
16.             End If
    
17.             wb.Close False
    
18. 100:
    
19.             strFile = Dir
    
20.         Loop
    
21.         .Columns("A:F").AutoFit
    
22.         .UsedRange.EntireRow.AutoFit
    
23.     End With
    
24.     Application.ScreenUpdating = True
    
25. End Sub

复制代码

冥王

林龙成 发表于 2015-10-1 14:45
我点击了之后是这个样子的？是哪里出了问题啊，能不能帮我更改一下

改了一下 再试试  5楼的 我这边运行是没有问题的

林龙成

冥王 发表于 2015-10-1 15:15
改了一下 再试试  5楼的 我这边运行是没有问题的

这次有用了，非常感谢！！！