VBA nested loop not working

Question

I have a group of files in a folder called 'inputs'. Each file contains several sheets laid out in exactly the same way, but containing different values. Each of these files also has a summary sheet listing all the sheet names in column A.

I need to

-open each file in turn -pull the values from each sheet into another book I have named 'consolidator' & calculate the consolidator sheet based on these values. -then copy and paste the result into an output file and save it. -I need to do this for every sheet in the book, and then for every file in the folder.

My code therefore contains a loop (to go through each sheet), within another loop (to go through each file).

THE PROBLEM is that my code runs and generates the correct output, if the sheet names in the files are the same (even if the file names are different).

However, if the sheet names in each file are different, on the second iteration of my 'file' loop, the code is interrupted with 'cannot find sheet name x in file name y (file name y in this instance has not changed from the first iteration).

Thanks in advance if you are able to help! :)

Here is my code:

Sub FileExtractor()
'SET KEY VARIABLES

Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim MyPathOutput As String
Dim i As Long
Dim LastRow As Long
Dim rngi As Range
Dim strx As String
Dim StrLen1 As Integer
Dim StrLen2 As Integer


calcsetting = Application.Calculation


'DEFINE FILE LOCATIONS
MyPath = ThisWorkbook.Path
If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\Inputs\"
    Else
    MyPath = MyPath & "Inputs\"
End If

' Change this to the path\folder location of your output file.
MyPathOutput = ThisWorkbook.Path

' If there are no Excel files in the responses folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
    MsgBox "No files found"
    Exit Sub
End If

' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
    FNum = FNum + 1
    ReDim Preserve MyFiles(1 To FNum)
    MyFiles(FNum) = FilesInPath
    FilesInPath = Dir()
Loop

' This sets various application properties. NB. Calculation mode is set to off, so all calculations must be forced
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

'define the name of the workbook that is running the macro
Set masterwks = ThisWorkbook



'BEGIN WORKING THROUGH FILES TO CONSOLIDATE INFO

'set row number where data will start to be pasted
cnum = 1
rnum = 1

' Loop through all files in the myFiles array.
If FNum > 0 Then
    For FNum = LBound(MyFiles) To UBound(MyFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))

        If Not mybook Is Nothing Then
            On Error Resume Next

            masterwks.Worksheets("Consolidator").Activate

            'update consolidator with new input file name
            newname = "[" & mybook.Name & "]"

            With masterwks.Worksheets("Consolidator")
            Currentname = .Range("filename")
            .Cells.Replace What:=Currentname, Replacement:= _
            newname, LookAt:=xlPart, SearchOrder:=xlByColumns, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
            End With

            LastRow = mybook.Sheets("summary").Range("A:A").Find("*", searchdirection:=xlPrevious).Row


            For i = 4 To LastRow


                Set rngi = mybook.Sheets("summary").Range("A" & i)

                StrLen1 = Len(rngi.Value)
                StrLen2 = StrLen1 - 1

                strx = Trim(Left(rngi.Value, StrLen2))


                newname2 = strx

                With masterwks.Worksheets("Consolidator")
                Currentname2 = .Range("sheetname")
                .Cells.Replace What:=Currentname2, Replacement:= _
                newname2, LookAt:=xlPart, SearchOrder:=xlByColumns, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
                End With


                Set sourceRange = masterwks.Sheets("consolidator").Range("outputrange")
                Calculate


                'CREATE OUTPUT FILE
                ' Add a new workbook with one sheet.
                Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
                With BaseWks
                    Sheets(1).Select
                    Cells(1, 1).Select
                End With


                'PASTE FILE DATA
                ' Set the destination range to A
                Set destrange = BaseWks.Range("A" & rnum)
                sourceRange.Copy
                destrange.PasteSpecial Paste:=xlPasteValues, Transpose:=False
                destrange.PasteSpecial Paste:=xlPasteFormats, Transpose:=False
                BaseWks.Columns.AutoFit
                BaseWks.SaveAs Filename:=MyPathOutput & "\" & masterwks.Sheets("consolidator").Range("sheetname") & " - " & mybook.Name

            Next i

        End If

        mybook.Close savechanges:=False

    Next FNum
End If
Application.Calculation = calcsetting

ExitTheSub:
' Restore the application properties.
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
End With

    MsgBox "Ta da!!"


Application.Calculation = calcsetting
End Sub

You could add code to loop all the worksheets in the each book and if .Name not like "Summary" then do .......... If you pulled out the code that actually does stuff in the worksheet into its own subroutine you could then have a loop each worksheet in current workbook and if name not like "Summary" call your subroutine. — QHarr, Oct 25 '17 at 14:07
Can you use the worksheet index (order) or the [codename](https://msdn.microsoft.com/en-us/vba/excel-vba/articles/worksheet-codename-property-excel)? — , Oct 25 '17 at 14:08
1) [Avoid using `.Select`/`.Activate`](https://stackoverflow.com/questions/10714251/), 2) You have a few `With` statements but don't actually use them. I.e. `With BaseWks // Sheets(1).Select // Cells(1,1.Select)`. There's no need to select a worksheet when using that `With BaseWsk`, just do `.Cells(1,1)`. ..but you then don't *use* that `.Select`, so why need it? — BruceWayne, Oct 25 '17 at 14:13
@qharr - I tried this just in case (though I think it is essentially the same process as my code above?), and the same thing happens — LTav, Oct 26 '17 at 09:44
@jeeped I may be wrong but don't think I can do this as the number of sheets varies in each book? — LTav, Oct 26 '17 at 09:45
@brucewayne thanks - this was left over from a previous project. — LTav, Oct 26 '17 at 09:51
Add the solution as an answer rather than editing it into the question. — QHarr, Oct 26 '17 at 13:04

score 0 · Accepted Answer · answered Oct 26 '17 at 13:53

SOLUTION:

Found the solution to my problem...

Replacing the filename in my consolidator sheet before replacing the sheetname works for the first iteration but not thereafter, because as excel replaces the filename in each individual cell, it then looks for the sheetname that is already in the cell (and sometimes this address doesn't exist).

I therefore changed my code to replace both the filename and sheetname at the same time, and this fixed the issue. Thanks everyone :)

Sub FileExtractor()
'SET KEY VARIABLES

Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim MyPathOutput As String
Dim StrLen1 As Integer
Dim StrLen2 As Integer
Dim ws As Worksheet
Dim bookname As String
Dim BaseName As String



calcsetting = Application.Calculation
Application.AskToUpdateLinks = False


'DEFINE FILE LOCATIONS
MyPath = ThisWorkbook.Path
If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\Inputs\"
    Else
    MyPath = MyPath & "Inputs\"
End If

' Change this to the path\folder location of your output file.
MyPathOutput = ThisWorkbook.Path
If Right(MyPathOutput, 1) <> "\" Then
    MyPathOutput = MyPathOutput & "\Outputs\"
    Else
    MyPath = MyPathOutput & "Outputs\"
End If


 ' If there are Excel files in the outputs folder, exit.
FilesInPath = Dir(MyPathOutput & "*.xl*")
If FilesInPath <> "" Then
    MsgBox "There are already files in the output folder."
    Exit Sub
End If

    ' If there are no Excel files in the responses folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
    MsgBox "No files found in inputs folder."
    Exit Sub
End If

' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
    FNum = FNum + 1
    ReDim Preserve MyFiles(1 To FNum)
    MyFiles(FNum) = FilesInPath
    FilesInPath = Dir()
Loop

' This sets various application properties. NB. Calculation mode is set to off, so all calculations must be forced
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

'define the name of the workbook that is running the macro
Set masterwks = ThisWorkbook



'BEGIN WORKING THROUGH FILES TO CONSOLIDATE INFO

'set row number where data will start to be pasted
cnum = 1
rnum = 1

' Loop through all files in the myFiles array.
If FNum > 0 Then
    For FNum = LBound(MyFiles) To UBound(MyFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            If Not mybook Is Nothing Then
              On Error Resume Next

              masterwks.Worksheets("Consolidator").Activate

                For Each ws In mybook.Worksheets

                    If ws.Name <> "Summary" Then

                        ws.Select

                        'update consolidator with new input file name
                        newname = "[" & mybook.Name & "]" & ws.Name

                        With masterwks.Worksheets("Consolidator")
                        Currentname = .Range("filename")
                        .Cells.Replace What:=Currentname, Replacement:= _
                        newname, LookAt:=xlPart, SearchOrder:=xlByColumns, _
                        MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
                        End With

                        Set sourceRange = masterwks.Sheets("consolidator").Range("outputrange")
                        Calculate


                        'CREATE OUTPUT FILE
                        ' Add a new workbook with one sheet.
                        Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

                        'PASTE FILE DATA
                        ' Set the destination range to A
                        Set destrange = BaseWks.Range("A" & rnum)
                        sourceRange.Copy
                        destrange.PasteSpecial Paste:=xlPasteValues, Transpose:=False
                        destrange.PasteSpecial Paste:=xlPasteFormats, Transpose:=False
                        BaseWks.Columns.AutoFit
                        bookname = mybook.Name
                        StrLen1 = Len(bookname)
                        StrLen2 = StrLen1 - 5
                        BaseName = Trim(Left(bookname, StrLen2))
                        BaseWks.SaveAs Filename:=MyPathOutput & "\" & BaseName & " - " & masterwks.Sheets("consolidator").Range("sheetname") & ".xlsx"
                        ActiveWorkbook.Close

                    End If

                Next ws

            End If

        mybook.Close savechanges:=False

    Next FNum

End If

Application.Calculation = calcsetting

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

    MsgBox "Ta da!!"


Application.Calculation = calcsetting
End Sub

VBA nested loop not working

1 Answers1