导入文件出现问题？

ylj518

要导入的是丙个xls文件，导入的是xlsm文件，导入出现问题如图

gwjkkkkk

加一个判断即可。

gwjkkkkk

Option Explicit
Sub 汇总工作簿()
Dim filePath, fileName, sht
filePath = ThisWorkbook.Path & "\"
fileName = Dir(filePath & "*.xls")
Application.ScreenUpdating = False
Do While fileName <> ""
   If fileName <> ThisWorkbook.Name Then
    With Workbooks.Open(filePath & fileName)
       For Each sht In .Worksheets
       sht.copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
       ActiveSheet.Name = sht.Name & "-" & Replace(.Name, ".xls", "")
       Next
       .Close False
   
    End With
    End If
    fileName = Dir
Loop
  Application.ScreenUpdating = True
End Sub

ylj518

请问gwjkkkkk怎么加呢，谢谢！

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.1.18
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set ws = ThisWorkbook
   
6.     Set sh = ws.Sheets("表1")
   
7.     For Each sht In ws.Sheets
   
8.         If sht.Name <> sh.Name Then sht.Delete
   
9.     Next
   
10.     p = ThisWorkbook.Path & ""
    
11.     For Each f In Fso.GetFolder(p).Files
    
12.         If f.Name Like "*.xls*" Then
    
13.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
14.                 fn = Fso.GetBaseName(f)
    
15.                 Set wb = Workbooks.Open(f, 0)
    
16.                 For Each sht In wb.Sheets
    
17.                     sht.copy after:=ws.Worksheets(ws.Worksheets.Count)
    
18.                     ActiveSheet.Name = sht.Name & "-" & fn
    
19.                 Next
    
20.                 wb.Close False
    
21.             End If
    
22.         End If
    
23.     Next f
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

ylj518

谢谢ykcbf1100！又是一种方法，值得学习！