求助

ykcbf1100

附件供参考。。。

wogoqo

ykcbf1100 发表于 2024-1-31 09:55
附件供参考。。。

感谢大神帮忙。
有个问题，对话框不能选择多个Excel文件呢，只能选择单个文件

wogoqo

wogoqo 发表于 2024-1-31 10:10
感谢大神帮忙。
有个问题，对话框不能选择多个Excel文件呢，只能选择单个文件

同名称的Sheet按照Excel规则在原名称的后面加（1）

cjc209

Sub tt()
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        If .Show = -1 Then
            Dim vrtselecteditem As Variant
            Dim tempwb As Workbook
            Set wb = Workbooks.Add
            For Each vrtselecteditem In .SelectedItems
                Set tempwb = Workbooks.Open(vrtselecteditem)
                tempwb.Sheets.Copy After:=wb.Sheets(wb.Sheets.Count)
                tempwb.Close (False)
            Next
            wb.SaveAs (ThisWorkbook.Path & "\结果.xlsx")
            wb.Close (True)
        End If
    End With
End Sub

wogoqo

选择多个文件后，只能复制单个工作薄的Sheet

szdcp

wogoqo 发表于 2024-1-31 10:10
感谢大神帮忙。
有个问题，对话框不能选择多个Excel文件呢，只能选择单个文件

.AllowMultiSelect =False 改为 True 就可以多选

ykcbf1100

多文件工作表复制。

1. Sub ykcbf2()  '//2024.1.31  '//多文件
   
2.     Dim fns
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set ws = ThisWorkbook
   
7.     Set sh = ws.Sheets("操作台")
   
8.     For Each sht In Sheets
   
9.         If sht.Name <> sh.Name Then sht.Delete
   
10.     Next
    
11.     p = ThisWorkbook.Path & ""
    
12.     With Application.FileDialog(msoFileDialogFilePicker)
    
13.         .InitialFileName = p
    
14.         .Title = "请选择对应Excel文件"
    
15.         .AllowMultiSelect = True
    
16.         .Filters.Clear
    
17.         .Filters.Add "Excel文件", "*.xls*"
    
18.         If .Show Then Set fns = .SelectedItems Else Exit Sub
    
19.     End With
    
20.     For Each f In fns
    
21.         Set wb = Workbooks.Open(f, 0)
    
22.         For Each sht In wb.Sheets
    
23.             fn = sht.Name
    
24.             d(fn) = d(fn) + 1
    
25.             sht.Copy after:=ws.Sheets(ws.Sheets.Count)
    
26.             ws.Sheets(Sheets.Count).Name = fn & IIf(d(fn) > 1, "(" & d(fn) & ")", "")
    
27.         Next
    
28.         wb.Close 0
    
29.     Next
    
30.     sh.Activate
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub

复制代码

ykcbf1100

多文件工作表复制，附件供参考。。。