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

Question

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

每个选项卡实际上都是一份银行对帐单（以不同的货币表示），因此所有选项卡的结构都相同。我找到了一个宏（我不是VBA方面的专家，所以这更多是关于"find and adapt"而不是"write by myself"）将它们全部合并，所以第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 设置

但是，在源工作簿中每个 sheet 的循环过程中都会出现重要的新位。它会执行您在初始代码中使用的检查 - 检查索引是否 > 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

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

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

excel

merge

filenames

vba

loops