Excel VBA - 遍历文件夹并将名称的某些部分添加到工作簿中的单元格

Question

我正在尝试执行一个简单的练习 - (1) 将多个选项卡（每个选项卡来自单独的文件）合并到单个文件（“宏文件”）中，(2) 根据这些选项卡中的某些单元格重命名所有选项卡.

每个选项卡实际上都是银行对账单（以不同的货币表示），因此所有选项卡都具有相同的结构。我找到了一个宏（我不是 VBA 专家，所以这更多是关于“查找和适应”而不是“自己编写”）将它们全部合并，所以步骤 1 没有问题。

但是，当我尝试一次重命名所有选项卡时，我遇到了冲突 - 三个选项卡与托管账户相关，四个选项卡与普通账户相关，并且账户之间存在货币交叉（例如，每个帐户都有美元和欧元）。

目前我有以下代码来重命名选项卡：

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

我正在寻找问题的解决方案：如果给定文件夹（与宏文件相同）中的文件包含“ESCROW”，则选项卡中单元格“D4”中的单元格值合并到宏文件应该从“USD”（让它成为美元银行对账单）更改为“Escrow USD”。 宏应该能够检查文件夹中的所有文件（据我了解，这是循环）并立即重命名相应的单元格。

这是我尝试写下的代码示例（虽然没有成功）：

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

如果有人能以某种方式帮助我，我将不胜感激。 欢迎任何问题（我理解我的语言可能有点棘手）。

更新。标签合并的当前代码如下（同样，这不是我的，只是用谷歌搜索它并插入到我的文件中，效果很好）：

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

在进入正题之前，我在这里和那里做了一些改变：

• 为了（希望）简单起见，对一些变量进行了重新排序和重命名
• 将文档过滤器更改为仅*.xl*，并稍后添加了一个辅助文件过滤器Instr(file, ".xl")
• 利用With 语句更改Application 设置

但是，在源工作簿中每个工作表的循环过程中都会出现重要的新位。它会执行您在初始代码中使用的检查 - 检查索引是否 > 2 以及文件名中是否包含“ESCROW” - 然后通过 With 语句相应地更改名称。

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