包含特定字符串的文件名会复制内容，并根据找到的字符串添加具有特定值的列

Question

我有以下问题。我喜欢20K xlsx文件，并希望将它们放到一个工作表中，现在工作得很好。

每个xlsx文件都有一个特定的字符串。

例如：

• Test_a_LME.xlsx
• Test_a_KZE.xlsx
• Test_b_LME.xlsx
• Test_a_KZE.xlsx

依此类推..

[我现在想要的是根据文件的结尾（LME和KZE）添加一个字符串（直到每个文件中数据的最后一行的范围）（请看图片）

到目前为止，这是我的代码：

Sub XlsMerger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Dim myFile As String

Application.ScreenUpdating = False


Set mergeObj = CreateObject("Scripting.FileSystemObject")
'Change folder path of excel files here
Set dirObj = mergeObj.getfolder("Folder")
Set filesObj = dirObj.Files
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

For Each everyObj In filesObj
    Set bookList = Workbooks.Open(everyObj)

    bookList.Activate
    Range("A4:A" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValuesAndNumberFormats)

    bookList.Activate
    Range("D4:E" & Range("D65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("D65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValuesAndNumberFormats)

    bookList.Activate
    Range("B4:B" & Range("B65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("F65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValuesAndNumberFormats)

Application.CutCopyMode = False
bookList.Close
Next
End Sub

我很确定我可能需要在for循环中添加一个if语句，但我不完全知道它的外观。

感谢您的事先帮助！

Answer 1

您需要确定LAST下划线在文件名中的位置，然后获取该文件名字符串的三个MIDDLE字符，从下划线开始的一个字符开始。

Option Explicit

Sub test()
    Dim fn As String
    fn = "Test_a_LME.xlsx"
    Dim pos1 As Long
    pos1 = InStrRev(fn, "_") + 1
    Debug.Print Mid$(fn, pos1, 3)
End Sub

Answer 2

未经测试：

Sub XlsMerger()
    Dim bookList As Workbook, fldr As Object
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Dim myFile As String, lastRow As Long, wsTarget As Worksheet, rwTarget As Range

    Application.ScreenUpdating = False


    Set mergeObj = CreateObject("Scripting.FileSystemObject")
    'Change folder path of excel files here
    Set dirObj = mergeObj.getfolder("Folder")
    Set filesObj = dirObj.Files
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

    Set wsTarget = ThisWorkbook.Worksheets(1)
    Set rwTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow

    For Each everyObj In filesObj

        Set bookList = Workbooks.Open(everyObj)

        With bookList.Sheets(1)
            'find last row using ColA
            lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

            'then use that same last row value to copy the 3 columns
            .Range("A4:A" & lastRow).Copy
            rwTarget.Columns("A").PasteSpecial xlPasteValuesAndNumberFormats

            .Range("D4:D" & lastRow).Copy
            rwTarget.Columns("D").PasteSpecial xlPasteValuesAndNumberFormats

            .Range("B4:B" & lastRow).Copy
            rwTarget.Columns("F").PasteSpecial xlPasteValuesAndNumberFormats

            'fill in the filename info: make adjustments here as needed
            rwTarget.Columns("B").Resize(lastRow - 3, 1).Value = bookList.Name

        End With

        Set rwTarget = rwTarget.Offset(lastRow - 3, 0) 'offset for next paste

        Application.CutCopyMode = False
        bookList.Close
    Next
End Sub