[已解决]将各个工作簿中的指定的工作表合成一个工作簿

colour250

紧急救助中，公司的系统不给力，只能一个一个月的导数据，导出来的数据要整成一个工作簿。
1、每个工作簿都包含有一个工作表“营业流水”，将该工作表复制出来并以原工作簿的名称命名组成一个新的工作簿。
2、最高一级要求希望能将所有该工作表数据整成一个工作表，并命名为2021年。如果无法实现，只能手动复制粘贴了，谢谢各位老师

最佳答案

月排行榜 / 总排行榜

林木水

2022-1-5 16:23

1. Sub 合并工作表()
   
2. On Error Resume Next
   
3. Application.DisplayAlerts = False
   
4. Dim f, i As Integer, j As Integer, wb As Workbook, k As Integer
   
5. Dim zb As Workbook, z1 As Integer, z2 As Integer, x As Integer
   
6. Set zb = Workbooks("合并工作表.xls")
   
7. f = Application.GetOpenFilename("xls格式,*.xls, xlsx格式,*.xlsx,xlsm格式,*.xlsm", 2, "选择需要合并的表格", MultiSelect:=True)
   
8. k = 1
   
9. z1 = 1
   
10. For i = zb.Sheets.Count To 1 Step -1
    
11.     If zb.Sheets(i).Name = "2021" Then
    
12.         zb.Sheets(i).Rows.ClearContents
    
13.     Else
    
14.         zb.Sheets(i).Delete
    
15.     End If
    
16. Next i
    
17. For i = 1 To UBound(f)
    
18.     Set wb = Workbooks.Open(f(i))
    
19.     For j = 1 To wb.Sheets.Count
    
20.         If wb.Sheets(j).Name = "营业流水" Then
    
21.             zb.Worksheets.Add.Name = VBA.Split(wb.Sheets(j).Parent.Name, ".")(0)
    
22.             wb.Sheets(j).UsedRange.Copy
    
23.             zb.Worksheets(VBA.Split(wb.Sheets(j).Parent.Name, ".")(0)).Range("a1").PasteSpecial (xlPasteValues)
    
24.             zb.Worksheets("2021").Range("a" & k).PasteSpecial (xlPasteValues)
    
25.             z2 = z1 + wb.Sheets(j).UsedRange.Rows.Count - 1
    
26.                 x = x + 1
    
27.                 If x Mod 2 = 0 Then
    
28.                     zb.Sheets("2021").Range("" & z1 & ":" & z2 & "").Interior.Color = vbYellow
    
29.                 End If
    
30.             If k = 1 Then
    
31.                 k = k + wb.Sheets(j).UsedRange.Rows.Count
    
32.             Else
    
33.                 zb.Worksheets("2021").Rows(k).Delete
    
34.                 k = k + wb.Sheets(j).UsedRange.Rows.Count - 1
    
35.             End If
    
36.             Exit For
    
37.         End If
    
38.     Next j
    
39.         wb.Close
    
40.         z1 = k
    
41. Next i
    
42. Application.DisplayAlerts = True
    
43. End Sub
    

复制代码

话不多说，看下效果

跳转到最佳答案楼层

林木水

1. Sub 合并工作表()
   
2. On Error Resume Next
   
3. Application.DisplayAlerts = False
   
4. Dim f, i As Integer, j As Integer, wb As Workbook, k As Integer
   
5. Dim zb As Workbook, z1 As Integer, z2 As Integer, x As Integer
   
6. Set zb = Workbooks("合并工作表.xls")
   
7. f = Application.GetOpenFilename("xls格式,*.xls, xlsx格式,*.xlsx,xlsm格式,*.xlsm", 2, "选择需要合并的表格", MultiSelect:=True)
   
8. k = 1
   
9. z1 = 1
   
10. For i = zb.Sheets.Count To 1 Step -1
    
11.     If zb.Sheets(i).Name = "2021" Then
    
12.         zb.Sheets(i).Rows.ClearContents
    
13.     Else
    
14.         zb.Sheets(i).Delete
    
15.     End If
    
16. Next i
    
17. For i = 1 To UBound(f)
    
18.     Set wb = Workbooks.Open(f(i))
    
19.     For j = 1 To wb.Sheets.Count
    
20.         If wb.Sheets(j).Name = "营业流水" Then
    
21.             zb.Worksheets.Add.Name = VBA.Split(wb.Sheets(j).Parent.Name, ".")(0)
    
22.             wb.Sheets(j).UsedRange.Copy
    
23.             zb.Worksheets(VBA.Split(wb.Sheets(j).Parent.Name, ".")(0)).Range("a1").PasteSpecial (xlPasteValues)
    
24.             zb.Worksheets("2021").Range("a" & k).PasteSpecial (xlPasteValues)
    
25.             z2 = z1 + wb.Sheets(j).UsedRange.Rows.Count - 1
    
26.                 x = x + 1
    
27.                 If x Mod 2 = 0 Then
    
28.                     zb.Sheets("2021").Range("" & z1 & ":" & z2 & "").Interior.Color = vbYellow
    
29.                 End If
    
30.             If k = 1 Then
    
31.                 k = k + wb.Sheets(j).UsedRange.Rows.Count
    
32.             Else
    
33.                 zb.Worksheets("2021").Rows(k).Delete
    
34.                 k = k + wb.Sheets(j).UsedRange.Rows.Count - 1
    
35.             End If
    
36.             Exit For
    
37.         End If
    
38.     Next j
    
39.         wb.Close
    
40.         z1 = k
    
41. Next i
    
42. Application.DisplayAlerts = True
    
43. End Sub
    

复制代码

话不多说，看下效果

colour250

林木水 发表于 2022-1-5 16:23
话不多说，看下效果

请问如果在“2021”这个工作表第一行要保持空白，怎么更改代码？即第二行才开始复制数据，因为第一行要写标头。谢谢

林木水

colour250 发表于 2022-1-5 22:13
请问如果在“2021”这个工作表第一行要保持空白，怎么更改代码？即第二行才开始复制数据，因为第一行要写 ...

代码第八行：把K=1改成K=2就可以了

colour250

林木水 发表于 2022-1-6 09:48
代码第八行：把K=1改成K=2就可以了

太感谢了！

林木水

colour250 发表于 2022-1-6 10:59
太感谢了！

还有那个第9行的Z1也要改一下，改成z1=2.其实这条不改也没事。哈哈，处于严谨考虑，改一下感觉要好些

colour250

林木水 发表于 2022-1-6 14:12
还有那个第9行的Z1也要改一下，改成z1=2.其实这条不改也没事。哈哈，处于严谨考虑，改一下感觉要好些

在你的代码上修改成了输入框，想实现在输入框里输入合并的工作表名称，这样就不需要去后台修改了，可是修改后却无法执行，请问能帮我检查下什么原因吗？万分感谢

林木水

colour250 发表于 2022-1-6 19:56
在你的代码上修改成了输入框，想实现在输入框里输入合并的工作表名称，这样就不需要去后台修改了，可是修 ...

你现在的需求应该跟之前的不一样了吧，现在是要做成哪样子的？

colour250

林木水 发表于 2022-1-6 20:50
你现在的需求应该跟之前的不一样了吧，现在是要做成哪样子的？

一样的，都是合并文件，但是之前那个合并的工作表名称【营业流水】，如果换成其他名称【销售人员】就需要去vba的代码里更改，我是想能否直接在工作表里点击那个输入框，然后在弹出的对话框里输入工作表名称就可以了而不需要去VBA代码里更改。

林木水

colour250 发表于 2022-1-6 22:02
一样的，都是合并文件，但是之前那个合并的工作表名称【营业流水】，如果换成其他名称【销售人员】就需要 ...

1. Sub 合并工作表()
   
2. Application.DisplayAlerts = False
   
3. Dim f, i As Integer, j As Integer, wb As Workbook, k As Integer
   
4. Dim zb As Workbook, z1 As Integer, z2 As Integer, x As Integer
   
5. Set zb = Workbooks("合并工作表.xls")
   
6. f = Application.GetOpenFilename("xls格式,*.xls, xlsx格式,*.xlsx,xlsm格式,*.xlsm", 2, "选择需要合并的表格", MultiSelect:=True)
   
7. k = 1
   
8. z1 = 1
   
9. For i = zb.Sheets.Count To 1 Step -1
   
10.     If zb.Sheets(i).Name = "2021" Then
    
11.         zb.Sheets(i).Rows.ClearContents
    
12.     Else
    
13.         zb.Sheets(i).Delete
    
14.     End If
    
15. Next i
    
16. Dim xx
    
17. xx = InputBox("需要合并哪个", "输入合并表")
    
18. If xx = "" Then End
    
19. For i = 1 To UBound(f)
    
20.     Set wb = Workbooks.Open(f(i))
    
21.     For j = 1 To wb.Sheets.Count
    
22.         If wb.Sheets(j).Name = xx Then
    
23.             zb.Worksheets.Add.Name = VBA.Split(wb.Sheets(j).Parent.Name, ".")(0)
    
24.             wb.Sheets(j).UsedRange.Copy
    
25.             zb.Worksheets(VBA.Split(wb.Sheets(j).Parent.Name, ".")(0)).Range("a1").PasteSpecial (xlPasteValues)
    
26.             zb.Worksheets("2021").Range("a" & k).PasteSpecial (xlPasteValues)
    
27.             z2 = z1 + wb.Sheets(j).UsedRange.Rows.Count - 1
    
28.                 x = x + 1
    
29.                 If x Mod 2 = 0 Then
    
30.                     zb.Sheets("2021").Range("" & z1 & ":" & z2 & "").Interior.Color = vbYellow
    
31.                 End If
    
32.             If k = 1 Then
    
33.                 k = k + wb.Sheets(j).UsedRange.Rows.Count
    
34.             Else
    
35.                 zb.Worksheets("2021").Rows(k).Delete
    
36.                 k = k + wb.Sheets(j).UsedRange.Rows.Count - 1
    
37.             End If
    
38.             Exit For
    
39.         End If
    
40.     Next j
    
41.         wb.Close
    
42.         z1 = k
    
43. Next i
    
44. Application.DisplayAlerts = True
    
45. End Sub

复制代码