[已解决]怎么在第二个文件夹中实现第一个文件夹中效果

乐乐2006201506

主要是文件格式问题，第一个文件夹中的是.xlsx,而第二个文件夹中的都是.xlsm。请解决这个问题，谢谢！

注：两个文件夹中都用总表中的汇总（修改汇总代码）按钮合并其他工作簿中的数据。

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-3 21:15

汇总程序如下：

1. Sub 汇总()
   
2.     Dim myPath$, ibook As Workbook, myFile$, myName$, iName1$, ibook1 As Workbook
   
3.     Dim iSheet As Worksheet
   
4.     myPath = ThisWorkbook.Path & ""
   
5.     Set ibook = Application.ThisWorkbook
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Application.AskToUpdateLinks = False
   
9.     For x = ibook.Sheets.Count To 1 Step -1
   
10.         If ibook.Sheets(x).Name <> "总表" Then ibook.Sheets(x).Delete
    
11.     Next x
    
12.    
    
13.     myName = Dir(myPath & "*.xlsm")
    
14.     Do While myName <> ""    ' 开始循环。
    
15.         If myName <> "总表.xlsm" Then
    
16.         Workbooks.Open (myPath & myName)
    
17.         Set ibook1 = ActiveWorkbook
    
18.         i = ActiveWorkbook.Sheets.Count
    
19.         For x = 1 To i
    
20.             iName1 = Sheets(x).Name
    
21.             For Each iSheet In ibook.Sheets
    
22.                 If iSheet.Name = iName1 Then
    
23.                     GoTo aa
    
24.                 End If
    
25.             Next
    
26.             ibook.Sheets.Add after:=ibook.Sheets(ibook.Sheets.Count)
    
27.             With ibook.Sheets(ibook.Sheets.Count)
    
28.                 .Name = iName1
    
29.                 .Range("b1") = "分表名"
    
30.                 .Range("D1") = "时间"
    
31.             End With
    
32. aa:
    
33.             With ibook.Sheets(iName1)
    
34.                 If .Range("C1") = "" Then .Range("C1") = iName1
    
35.                 .Range("B65536").End(xlUp).Offset(1).Value = Replace(myName, ".xlsm", "")
    
36.                 .Range("B65536").End(xlUp).Offset(, 1) = Sheets(x).Range("A1").Value
    
37.                 .Cells.EntireColumn.AutoFit
    
38.             End With
    
39.             
    
40.         Next x
    
41.         ibook1.Close
    
42.         End If
    
43.     myName = Dir    ' 查找下一个目录。
    
44. Loop
    
45. Application.DisplayAlerts = True
    
46. Application.ScreenUpdating = True
    
47. End Sub

复制代码

这里我把更新连接关闭了，如果你要启用的话设置Application.AskToUpdateLinks = True

跳转到最佳答案楼层

老司机带带我

汇总程序如下：

1. Sub 汇总()
   
2.     Dim myPath$, ibook As Workbook, myFile$, myName$, iName1$, ibook1 As Workbook
   
3.     Dim iSheet As Worksheet
   
4.     myPath = ThisWorkbook.Path & ""
   
5.     Set ibook = Application.ThisWorkbook
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Application.AskToUpdateLinks = False
   
9.     For x = ibook.Sheets.Count To 1 Step -1
   
10.         If ibook.Sheets(x).Name <> "总表" Then ibook.Sheets(x).Delete
    
11.     Next x
    
12.    
    
13.     myName = Dir(myPath & "*.xlsm")
    
14.     Do While myName <> ""    ' 开始循环。
    
15.         If myName <> "总表.xlsm" Then
    
16.         Workbooks.Open (myPath & myName)
    
17.         Set ibook1 = ActiveWorkbook
    
18.         i = ActiveWorkbook.Sheets.Count
    
19.         For x = 1 To i
    
20.             iName1 = Sheets(x).Name
    
21.             For Each iSheet In ibook.Sheets
    
22.                 If iSheet.Name = iName1 Then
    
23.                     GoTo aa
    
24.                 End If
    
25.             Next
    
26.             ibook.Sheets.Add after:=ibook.Sheets(ibook.Sheets.Count)
    
27.             With ibook.Sheets(ibook.Sheets.Count)
    
28.                 .Name = iName1
    
29.                 .Range("b1") = "分表名"
    
30.                 .Range("D1") = "时间"
    
31.             End With
    
32. aa:
    
33.             With ibook.Sheets(iName1)
    
34.                 If .Range("C1") = "" Then .Range("C1") = iName1
    
35.                 .Range("B65536").End(xlUp).Offset(1).Value = Replace(myName, ".xlsm", "")
    
36.                 .Range("B65536").End(xlUp).Offset(, 1) = Sheets(x).Range("A1").Value
    
37.                 .Cells.EntireColumn.AutoFit
    
38.             End With
    
39.             
    
40.         Next x
    
41.         ibook1.Close
    
42.         End If
    
43.     myName = Dir    ' 查找下一个目录。
    
44. Loop
    
45. Application.DisplayAlerts = True
    
46. Application.ScreenUpdating = True
    
47. End Sub

复制代码

这里我把更新连接关闭了，如果你要启用的话设置Application.AskToUpdateLinks = True