如何复制工作簿的一张纸

Question

我尝试复制已关闭工作簿的所有工作表并将其粘贴到我正在使用的工作簿中。

我尝试了以下代码：

Sub copy_Ws()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sourceWb As Workbook
    Dim sh As Worksheet: Set sh = wb.Worksheets(1)
    Dim sourceWs As Worksheet
    
    Dim cell As Range: Set cell = sh.Range("C1:C50")
    Dim currentCell As Range
    Dim filename As String
    Dim sourceWbName As String
    Dim path As String

        
    For Each currentCell In cell
    If IsEmpty(currentCell) = False Then
        On Error Resume Next
        Set sourceWb = Workbooks(currentCell.Value)
        Debug.Print (currentCell.Value)
        For Each ws In sourceWb.Sheets
            ' Copy the worksheet
            ws.Copy After:=wb.Sheets(wb.Sheets.Count)
        Next ws
        On Error GoTo 0
    End If
    Next currentCell
    
End Sub

只需知道当前Cell中保存的是路径。

我的问题是我得到类似 Index out ofbounds 9 的东西 编译器向我显示以下行“Set sourceWb = Workbooks(currentCell.Value)”

我该怎么做才能获得所需的工作簿？

提前谢谢您

Answer 1

从列表中的多个文件导入所有工作表

Sub ImportWorkSheets()
' Charts:
' To also allow importing charts, replace:
'     'sws As Worksheet' with 'sws As Object' (there is no 'Sheet' object) and
'     '... In swb.Worksheets' with '... In swb.Sheets'
' I would also replace 'sws' with 'ssh'.
' Hidden:
' If a sheet is hidden it will be copied hidden.
' If a sheet is very hidden, it will not be copied (no alert).
' You could add some code in the 'For Each sws... 'loop to modify this behavior.
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    Dim dws As Worksheet: Set dws = dwb.Worksheets(1)
    Dim drgList As Range: Set drgList = dws.Range("C1:C50")
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, dcell As Range
    Dim swbPath As String, swbName As String, WasWorkbookOpen As Boolean
    
    For Each dcell In drgList.Cells
        swbPath = CStr(dcell.Value)
        If Len(swbPath) > 0 Then ' cell is not blank
            swbName = Dir(swbPath)
            If Len(swbName) > 0 Then ' file (workbook) exists
                On Error Resume Next
                    Set swb = Workbooks(swbName)
                On Error Resume Next
                If swb Is Nothing Then ' workbook is not open
                    Set swb = Workbooks.Open(swbPath)
                Else ' workbook is open
                    If StrComp(swb.FullName, swbPath, vbTextCompare) <> 0 Then
                    ' wrong workbook open!!!
                        MsgBox "A workbook named """ & swb.Name _
                            & """ from another location (""" & swb.path _
                            & """) is open! Cannot process!", vbExclamation
                        Set swb = Nothing ' wrong workbook is open
                    Else ' correct workbook open
                        WasWorkbookOpen = True
                    End If
                End If
                If Not swb Is Nothing Then ' workbook is referenced (set)
                    If Not swb Is dwb Then ' it's not the destination workbook
                        For Each sws In swb.Worksheets
                            sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
                        Next sws
                        If WasWorkbookOpen Then ' workbook was open
                            WasWorkbookOpen = False ' reset
                        Else ' workbook was not open
                            swb.Close SaveChanges:=False
                        End If
                    'Else ' it's the destination workbook; do nothing
                    End If
                    Set swb = Nothing ' reset
                'Else ' workbook is not referenced (set); do nothing
                End If
            'Else ' file (workbook) doesn't exist; do nothing
            End If
        'Else ' cell is blank; do nothing
        End If
    Next dcell
    
    Application.ScreenUpdating = True
    
    MsgBox "Worksheets imported.", vbInformation
    
End Sub