Excel VBA - Loop through folder and add certain parts of names to cells in workbook

Question

I'm trying to perform a simple exercise - (1) merge several tabs (each from separate file) into single file ("macro-file"), (2) rename all tabs in accordance with certain cells in these tabs.

Each tab is effectively a bank statement (in different currencies), so all tabs are of the same structure. I've found a macro (I'm not a specialist in VBA, so this is more about "find and adapt" than "write by myself") to merge them all, so there is no problem with step 1.

However, when I'm trying to rename all tabs at once, I'm getting a conflict - there are three tabs relating to Escrow Account and four tabs relating to Ordinary Account, and there is an intersection in currencies between accounts (each account has USD and EUR, for example).

Currently I have the following code to rename the tabs:

Sub RenameSheet ()
    Dim rs As Worksheet
    For Each rs In Sheets
        If rs.Index > 2 Then
            rs.Name = rs.Range("D4")
        End If
    Next rs
End Sub

What I'm looking for is the solution for problem: if file in a given folder (same as the macro-file) contains "ESCROW", then cell value in cell "D4" in the tab merged to macro-file should be changed from "USD" (let it be a USD bank statement) to "Escrow USD". The macro should be able to check all files in folder (this is Loop, as far as I understand) and rename respectful cells at once.

Here is the example of code I tried to write-down (unsucessfully though):

Sub RenameSheet ()
    Dim fName As String, wb As Workbook, rs As Worksheet

    For Each rs In Sheets
        If rs.Index > 2 Then

            Const myPath As String = "C:\Users\my folder"
            If Right(myPath, 1) <> "\" Then fPath = myPath & "\"

            fName = Dir(fPath & "*Full*.xlsx*")
            v = "ESCROW"

            Do Until fName <> ""
                If InStr(1, fName, v) > 0 Then
                    rs.Name = "ESCROW" + rs.Range("D4")
                Else
                    rs.Name = rs.Range("D4")
                End If
            Loop

        End If
    Next rs

End Sub

If any of you could help me somehow, I will be grateful. Any questions are welcome (I understand my language can be a bit tricky).

UPDATE. Current code for tabs merging is below (again, that's not mine, only googled it and inserted to my file, works perfectly):

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook

    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

                Set wbkSrcBook = Workbooks.Open(FileName:=fnameCurFile)

                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Copyafter:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next

                wbkSrcBook.Close SaveChanges:=False

            Next

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

            MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If

    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

Answer 1

There are a few things here and there that I changed before getting to the point:

• Reordered and renamed some variables for (hopefully) simplicity
• Changed the filter on documents to just *.xl* and added a secondary file filter later with Instr(file, ".xl")
• Utilized the With statement for changing the Application settings

But, the important new bit comes in during the loop on each sheet in the source workbook. It does the checks that you used in the initial code - checking if index > 2 and whether "ESCROW" is in the filename - then changes the name accordingly via a With statement.

Sub MergeExcelFiles()

    Dim fnameList, fnameCurFile As Variant
    Dim wbkDestBook, wbkCurSrcBook As Workbook
    Dim countFiles, countSheets As Long
    Dim wksCurSheet As Worksheet

    fnameList = Application.GetOpenFilename( _
        FileFilter:="Microsoft Excel Workbooks (*.xl*),*.xl*", _
        Title:="Choose Excel files to merge", _
        MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then

            With Application
                .ScreenUpdating = False
                .Calculation = xlCalculationManual
            End With

            Set wbkDestBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                If InStr(LCase$(fnameCurFile), ".xl") > 0 Then  'second file filter 'prevents e.g. shortcuts (.html files) that can get this far

                    Set wbkCurSrcBook = Workbooks.Open(filename:=fnameCurFile)

                    For Each wksCurSheet In wbkCurSrcBook.Sheets

                        wksCurSheet.copy after:=wbkDestBook.Sheets(wbkDestBook.Sheets.count)

                        'renaming here
                        If wbkDestBook.Sheets.count > 2 Then

                            With wbkDestBook.Sheets(wbkDestBook.Sheets.count)
                                If InStr(UCase$(fnameCurFile), "ESCROW") Then
                                    .Name = "ESCROW " & .Range("D4").Value2
                                Else
                                    .Name = .Range("D4").Value2
                                End If
                            End With

                        End If
                        'end of renaming

                        countSheets = countSheets + 1
                    Next

                    wbkCurSrcBook.Close SaveChanges:=False

                    countFiles = countFiles + 1
                End If
            Next

            With Application
                .ScreenUpdating = True
                .Calculation = xlCalculationAutomatic
            End With

            MsgBox "Procesed " & countFiles & " files." & vbCrLf & "Merged " & countSheets & " worksheets.", Title:="Merge Excel files"
        End If

    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If

End Sub