How to fix error code 'subscript out of range' (run-time error '9')? 2

[feipezi]

Hello,
Hope you all doing well and staying far far away from COVID 19.
What i'm trying to do is to copy all the tabs of all the workbooks in a folder into a single workbook. But I have 2 errors :
one is from the statement:
Set nusheet = Workbooks(basebook).Worksheets.Add.
But if I take 'ThisWorkbook' instead of "Workbooks(basebook)" then fine. I just cannot figure out why 'basebook' is not working.
The other one is from the statement:
oFile.Close SaveChanges:=False, I have a '438' for it: object does not support the method or property. I need the statement since I don't want all the books open after I finish using them.
Thanks in advance.


Sub CopyMultiBooksInOne()
Dim strPath As String
Dim oFSO As Object
Dim oFile As Object
Dim oFolder As Object
Dim obook As Object

strPath = "C:\Users\pl04512\Documents\pnc\Franktest\Aja\CRE"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(strPath)
basebook = "Book1.xlsx"

For Each oFile In oFolder.Files
If oFile.Name Like "*.xlsx" Then
Set obook = Workbooks.Open(oFile)
For Each st In obook.Worksheets
Set nusheet = Workbooks(basebook).Worksheets.Add
nusheet.Name = st.Name
' st.UsedRange.Copy Workbooks(basebook).Worksheets(st.Name).Cells(1, 1)
' Workbooks(basebook).Worksheets(st.Name).UsedRange.EntireColumn.AutoFit
Next
End If
oFile.Close SaveChanges:=False
Next

Set oFSO = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub

 

[strongm]

So ...

1. oFile does not represent an excel workbook, it represents a file. You want oBook here instead. And the line is in the wrong place ... instead of

[COLOR=blue]nusheet.Name = st.Name
' st.UsedRange.Copy Workbooks(basebook).Worksheets(st.Name).Cells(1, 1)
' Workbooks(basebook).Worksheets(st.Name).UsedRange.EntireColumn.AutoFit
Next
End If
oFile.Close SaveChanges:=False
Next[/color]

you want

[COLOR=blue]nusheet.Name = st.Name
' st.UsedRange.Copy Workbooks(basebook).Worksheets(st.Name).Cells(1, 1)
' Workbooks(basebook).Worksheets(st.Name).UsedRange.EntireColumn.AutoFit
Next
oBook.Close SaveChanges:=False
End If
Next[/color]

2. Are you quite sure that basebook is an OPEN workbook when you hit

[COLOR=blue]Set nuSheet = Workbooks(basebook).Worksheets.Add[/color]

 

[combo]

[tt]basebook = "Book1.xlsx"[/tt]

But if I take 'ThisWorkbook' instead of "Workbooks(basebook)" then fine. I just cannot figure out why 'basebook' is not working.

ThisWorkbook refers to the workbook with calling code, basebook is a workbook without vba code (xlsx typed), if you intend to point the same workbook in the example, you should have 'xlsm' extension. Anyway, it's the case strongm pointed.

combo

 

[feipezi]

Thanks guys. Your reply is very informative.
Here is the code that works. I am unable to figure out why BASEBOOK not working. I saved 'Book1.xlsx' as 'Book1.xlsm' as what combo suggested and still no luck. Only 'ThisWorkBook' works for me.
Now I'm trying to figure out something else.
Under the 2nd ThisWorkBook statements (ThisWorkBook,....,=obook.name), I'm trying to create another column that is based on obook.name. If the obook.name contains 'Total' or 'Fund' then the new column that I call it 'Suffix' will be like 'Tot' or 'Fun'. My question is if I can take SELECT CASE... END SELECT to do the job? I checked my old code and did not see anything like

SELECT CASE OBOOK.NAME
CASE INSTR(OBOOK.NAME,"TOTAL")
"TOT"
....
....
END SELECT
I used quite some SWITCH() and I like it. Not sure if it can fit in there:

Function Suffix(bookname As String)
Suffix = Switch(InStr(bookname, "TOTAL"), "_T", InStr(bookname, "_FUND"), "_F", InStr(bookname, "_UNF"), "_U")
End Function



But it won't let me to use 'obook.name'.
The last resort will be IF/THEN way of doing it. Now I have only 3 values; what if I have 30 values. It will be messy with IF/THEN.

Thanks again.
Take care.

Public Const CREfolder As String = "C:\Users\pl04512\Documents\pnc\Franktest\Aja\CRE\Original"

Sub ListMultiBooksMultiTab()
Application.ScreenUpdating = False
Dim strPath As String
Dim oFSO As Object
Dim oFile As Object
Dim oFolder As Object
Dim obook As Object
Dim basebook As Object

strPath = CREfolder
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(strPath)
' MsgBox ThisWorkbook.Name
For Each oFile In oFolder.Files
If oFile.Name Like "*.xlsx" Then
Set obook = Workbooks.Open(oFile)
x = ThisWorkbook.ActiveSheet.Cells(1, 1).CurrentRegion.Rows.Count
i = 1
For Each st In obook.Worksheets
ThisWorkbook.ActiveSheet.Cells(x + i, 1) = st.Name
ThisWorkbook.ActiveSheet.Cells(x + i, 2) = obook.Name
i = i + 1
Next
End If
obook.Close SaveChanges:=False
Next

Set oFSO = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Application.ScreenUpdating = True
End Sub

 

[strongm]

You can get the Select thing working by playting a little trick on VB - change

[tt]SELECT CASE OBOOK.NAME[/tt]

to

[tt]Select Case True[/tt]

 

[Andrzejek]

Also, please format your code as code, not just Bold font.
Use 'Preview' button before 'Submit Post' to see how your post will look like.


---- Andy

There is a great need for a sarcasm font.

 

[combo]

I haven't suggested to rename the workbook. The issue is that a workbook named Book1.xlsx is not open when you call it (in opposite to ThisWorkbook, so the difference).

combo

 

[strongm]

>The issue is that a workbook named Book1.xlsx is not open

Yup. Wonder how many times we need to repeat this ...

 

[feipezi]

Hello guys,
Thanks for all your answers. I'll stay with ThisWorkBook and I like it because it will identify any active workbook instead of bothering about the name of the open workbook.

Now I'm making progress in combining multiple sheets from multiple workbooks into a single one. The major issues are that there will be more than one sheet with the same name. I tried to rename some of the tabs based on the workbook name; but still there are more dups coming up; I tried ON ERROR GOTO FIXED: FOR X=1 TO 3 NUSHEET.NAME=ST.NAME & "_" & X, which only renamed one of the dups. Do we have a something like 'RETURN' statements to make the process go back and check again on dups? Btw, as I got the error, it says: Run-time error: 1004 that name is already taken. Try a different one...

Thanks in advance.

Here is the code:

Sub CombineMultiBooksMultiTabsCARD()
Application.ScreenUpdating = False
Dim strPath As String
Dim oFSO As Object
Dim oFile As Object
Dim oFolder As Object
Dim obook As Object

strPath = SourceFolder
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(strPath)
' MsgBox ThisWorkbook.Name
For Each oFile In oFolder.Files
If oFile.Name Like "*.xlsx" Then
Set obook = Workbooks.Open(oFile)
For Each st In obook.Worksheets
If Len(st.Name) > 27 Then st.Name = Mid(st.Name, 1, 23)

If InStr(obook.Name, "CCARD") Then
suffx = "_CC"
suffx_l = "_CCARD"
ElseIf InStr(obook.Name, "CALCOP") Then
suffx = "_CAL"
suffx_l = "_CALCP"
ElseIf InStr(obook.Name, "_Fund") Then
suffx = "_FUN"
suffx_l = "_FUND"
End If
On Error GoTo fixit
Set nusheet = ThisWorkbook.Worksheets.Add
If Len(st.Name) < 25 Then
nusheet.Name = st.Name & suffx_l
st.UsedRange.Copy ThisWorkbook.Worksheets(st.Name & suffx_l).Cells(1, 1)
ThisWorkbook.Worksheets(st.Name & suffx_l).UsedRange.EntireColumn.AutoFit
Else
nusheet.Name = st.Name & suffx
st.UsedRange.Copy ThisWorkbook.Worksheets(st.Name & suffx).Cells(1, 1)
ThisWorkbook.Worksheets(st.Name & suffx).UsedRange.EntireColumn.AutoFit
End If
Next
End If
obook.Close SaveChanges:=False
Next
fixit: For x = 1 To 3
nusheet.Name = st.Name & "_" & x
Next
Set oFSO = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Application.ScreenUpdating = True
End Sub

 

[Andrzejek]

Did you declare [tt]SourceFolder, st, suffx, suffx_l, nusheet, x[/tt], etc. someplace else?


---- Andy

There is a great need for a sarcasm font.

 

[combo]

I'll stay with ThisWorkBook and I like it because it will identify any active workbook instead of bothering about the name of the open workbook.

No, ThisWorkbook returns the workbook containing the calling it code, whenever it is active or not. If you plan to process it, then ok.

combo

 

[feipezi]

Hello Andrzejek,
No, I did not declare the items that you mentioned. I know it's not orthodox doing so. But it's a test, not the final product. However, I don't think the error come from no declaration on those items, do you?
What I'm asking for is like adding tabs like 'sheet1', 'sheet2',...,'sheet10'; as Excel sees 'sheet10', which is already in the workbook, it will add a letter like 'X' or a number and make it 'sheet10X', as the new name of the sheet. Now the dups in name get resolved. The code attached can do that but only does it once. it won't be able to handle the 2nd duplicate and upward, if any.
Thanks.

Thanks combo for your comments.

 

[Andrzejek]

>I don't think the error come from no declaration on those items,
No, they don't. I just always use [tt]Option Explicit[/tt], but that's me...

Does it matter what are the names of your worksheets in your new workbook? Can you just keep naming them sheet1, sheet2, sheet3, ..., sheet125 ?

I see you detect 3 workbboks' names here:

If InStr(obook.Name, "CCARD") Then
  suffx = "_CC"
  suffx_l = "_CCARD"
ElseIf InStr(obook.Name, "CALCOP") Then
  suffx = "_CAL"
  suffx_l = "_CALCP"
ElseIf InStr(obook.Name, "_Fund") Then
  suffx = "_FUN"
  suffx_l = "_FUND"
End If

but if you have 52 workbooks, this naming style probably will not work. Especially if you have workbooks like: [tt]Bob_Fund, Susie_Fund, John_Fund[/tt], etc.

If you really do need to have them named and keep them unique, I would create a little Function that accepts Sheet's name and returns a sheet's name. If the name passed does not exist yet, this Function will just return passed name back. Otherwise, you can easily add 'X' and return the new, unique sheet's name (as long as it is a valid sheet's name).


---- Andy

There is a great need for a sarcasm font.

 

[combo]

There are some issues in your code.

If no error:
[tt]Set obook = Workbooks.Open(oFile)
For Each st In obook.Worksheets
...
Next ' For Each st In obook.Worksheets
End If
obook.Close SaveChanges:=False
Next ' For Each oFile In oFolder.Files
nusheet.Name = st.Name & "_" & x[/tt]
Last st is in closed file

In:
[tt]fixit: For x = 1 To 3
nusheet.Name = st.Name & "_" & x
Next[/tt]
Nusheet name is renamed three times, finally ending with '_3'.

I'm totally with Andy, create a simple function for testing if you can use given sheet's name or returning first name satisfying some schema. For instance (here already assigning free 0-9 suffix):
[pre]On Error Resume Next
For x=0 to 9
nusheet.Name = st.Name & "_" & x
If Err.Number <>0 Then
Err.Clear
Else
Exit For
End If
Next i[/pre]

combo

 

[strongm]

Something like this may be a slightly better starting point, lets Excel do most of the heavy lifting (e.g ensuring exact copies of the sheets, and doing any in initial renaming):

[blue]Sub CombineMultiBooksMultiTabsCARD()
    Application.ScreenUpdating = False
    Dim strPath As String
    Dim oFSO As Object
    Dim oFile As Object
    Dim oFolder As Object
    
    Dim mainWorkbook As Workbook
    Dim tempWorkSheet As Worksheet
    Dim sourceWorkbook As Workbook

    strPath = SourceFolder
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(strPath)

    Set mainWorkbook = Application.ActiveWorkbook
    For Each oFile In oFolder.Files
        If oFile.Name Like "*.xlsx" Then
            Workbooks.Open oFile
            Set sourceWorkbook = ActiveWorkbook
            For Each tempWorkSheet In sourceWorkbook.Worksheets
                tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
            Next
            sourceWorkbook.Close
        End If
    Next
    Application.ScreenUpdating = True
End Sub[/blue]

 

[strongm]

In fact, try:

[blue]Sub CombineMultiBooksMultiTabsCARD()
    Application.ScreenUpdating = False
    Dim strPath As String
    Dim oFile As Object   
    Dim mainWorkbook As Workbook
    Dim tempWorkSheet As Worksheet
    Dim sourceWorkbook As Workbook

    strPath = SourceFolder
    
    Set mainWorkbook = Application.ActiveWorkbook
    With CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
        For Each oFile In .Files
            If oFile.Name Like "*.xlsx" Then
                Workbooks.Open oFile
                Set sourceWorkbook = ActiveWorkbook
                RenameSheets sourceWorkbook
                For Each tempWorkSheet In sourceWorkbook.Worksheets
                    tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
                Next
                sourceWorkbook.Close SaveChanges:=False
            End If
        Next
    End With
    
    Application.ScreenUpdating = True
End Sub

Private Sub RenameSheets(oBook As Workbook)
    Dim st As Worksheet
    
    For Each st In oBook.Worksheets
        st.Name = Left(st.Name, 23)
        Select Case True
            Case InStr(oBook.Name, "CCARD")
                st.Name = st.Name & IIf(Len(st.Name) < 25, "_CCARD", "_CC")
            Case InStr(oBook.Name, "CALCOP")
                st.Name = st.Name & IIf(Len(st.Name) < 25, "_CALCP", "_CAL")
            Case InStr(oBook.Name, "_Fund")
                st.Name = st.Name & IIf(Len(st.Name) < 25, "_FUND", "_FUN")
        End Select
    Next
    
End Sub[/blue]