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

Question

我有以下问题。我有20K个xlsx文件，想把它们放到一个工作表中，现在工作得很好。

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

例如

• Test_a_LME.xlsx。
• 测试_a_KZE.xlsx
• 测试_b_LME.xlsx
• 测试_a_KZE.xlsx

以此类推...

我现在想要的是，我添加一个字符串(Range直到每个文件的最后一行数据)基于文件的结束(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

未测试。

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

Answer 2

你需要确定这个文件的位置 最后 的下划线，然后得到三个 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