求助

wogoqo

作用：用宏打开文件夹，能选择Excel文件，将选择的文件所有Sheet复制到新的工作表中

运行代码报错，是个新手，求大神帮忙。

Sub tt()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
    Dim mainwb As Workbook
    Set mainws = ThisWorkbook
    If .Show = -1 Then
        Dim vrtselecteditem As Variant
        Dim i As Integer
        
        i = 1
        For Each vrtselecteditem In .SelectedItems
            Dim tempwb As Workbook
            Set tempwb = Workbooks.Open(vrtselecteditem)
            tempwb.Worksheets(Sheets.Count).Copy After:=ThisWorkbook.Sheets(i)
            ThisWorkbook.Sheets(i).Name = VBA.Replace(tempwb.Name, ".xls", "")
            tempwb.Close savechanges:=False
            i = i + 1
        Next
    End If
    End With
    Set fd = Nothing
   
End Sub

wogoqo

求助大神帮忙，如何实现想要的工作

ykcbf1100

wogoqo 发表于 2024-1-30 20:41
求助大神帮忙，如何实现想要的工作

附件失效，请重新上传附件

liulang0808

Application.FileDialog(msoFileDialogFilePicker)
楼主换这个处理吧，
目前楼主是打开文件夹，没有选中文件的

wogoqo

重新上付附件

wogoqo

求大神帮忙

417744370

Sub 多选汇总到一个工作簿中分工作表()
Dim str()
Dim i As Integer
Dim wb, wb1 As Workbook
Dim sht As Worksheet

On Error Resume Next
Set wb1 = ActiveWorkbook
Set sht1 = ActiveSheet
On Error Resume Next
str = Application.GetOpenFilename("Excel数据文件,*.xls*", , , , True)
    For i = LBound(str) To UBound(str)
        Set wb = Workbooks.Open(str(i))
          For Each sht In wb.Sheets
            sht.Copy after:=wb1.Sheets(wb1.Sheets.Count)
            wb1.Sheets(wb1.Sheets.Count).Name = Split(wb.Name, ".")(0) & sht.Name
          Next
        wb.Close
    Next
End Sub
试试这段代码能否帮到您

szdcp

新手测试一下，不知道是不是楼主想要的效果

wogoqo

szdcp 发表于 2024-1-31 09:13
新手测试一下，不知道是不是楼主想要的效果

不得呢，没有将选择Excel所有的Sheet移动到当前工作薄

ykcbf1100

参与一下。。。

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

复制代码