I try to copy all sheets of a closed workbook and paste it in the workbook I am working with.
I tried following code:
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
Just that you know in the currentCell are the paths saved.
My problem is that I get something like Index out of bounds 9 and the compiler is showing me following line "Set sourceWb = Workbooks(currentCell.Value)"
What can I do to get the needed workbook?
Thank you in advance
When a file is open, you create a reference to it by using its name (not its path!), e.g.:
Set wb = Workbooks("Test.xlsx")
When a file is closed, you need to use the Open
method to open it and create a reference to it by using its path, e.g.:
Set wb = Workbooks.Open("C:\Test\Test.xlsx")
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 ' prevent error if file not open
Set swb = Workbooks(swbName)
On Error Resume Next
If swb Is Nothing Then ' workbook is not open
On Error Resume Next ' prevent error if not Excel file
Set swb = Workbooks.Open(swbPath)
On Error Resume Next
Else ' workbook is open
If StrComp(swb.FullName, swbPath, vbTextCompare) = 0 Then
' workbook from the given location open
If swb Is dwb Then ' it's the destination workbook
Set swb = Nothing ' reset; remains open
Else ' it's not the destination workbook
WasWorkbookOpen = True
End If
Else ' workbook from a different location open!!!
MsgBox "A workbook named """ & swb.Name _
& """ from another location (""" & swb.path _
& """) is open! Cannot process!", vbExclamation
Set swb = Nothing ' reset; remains open
End If
End If
If Not swb Is Nothing Then ' workbook is referenced (set)
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; remains open
Else ' workbook was closed
swb.Close SaveChanges:=False ' gets closed
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