VBA - Loop files in folder, search column for keyword, copy range of text to spreadsheet

[dinokovac93]

Hello everyone,

I'm trying to create a VBA program that will do the following steps

1. Loop through excel files in specified folder
2. Go through each file
3. Search in column B for "INTL" and/or "TRAX"
4. If "INTL" is found in column B, select that cell, move one cell over to column C, and copy all data in that table range (basically pressing Control + A) then paste the data in "original" spreadsheet in the next empty row.
5. If "TRAX" is found in column B, select that cell, move one cell over to column C, and copy all data in that table range (basically pressing Control + A) then paste the data in "original" spreadsheet in the next empty row.
6. If both keywords are found, both sections should be pasted. If only one is found, then only the found one should be pasted.
7. Close file and move to next sheet.

I'm not that good at VBA but I'm trying to learn it. I found a loop VBA code online but I'm having a hard time adding the if statements and actions of copying and pasting. Any help would be appreciated. Please let me know if you need additional info.

 

[Yongle]

Try this
- it does what you requested (Current Region is the VBA equivalent of CTRL-A)
- one match for each of the 2 values is performed in the first sheet of each workbook
- I suspect the initial output may not be exactly as desired
- if that is the case let me know what is wrong and post supporting sample source data so that I can see what you need
(consider using XL2BB)

For the 1st test ....
Create a NEW workbook
In VBA editor, insert a new module and paste the code below into that module
Amend the path "C:\folder\SpecifiedFolder"
Run the code

Sub LoopFiles()
    Dim wb As Workbook, Orig As Worksheet, sh As Worksheet
    Dim Func As WorksheetFunction, colB As Range, StrFile As String
    Const INTL = "INTL", TRAX = "TRAX"
    Set Func = WorksheetFunction
    Set Orig = ThisWorkbook.Sheets(1)
    Const fpath = "C:\folder\SpecifiedFolder"
    StrFile = Dir(fpath & "\" & "*.xlsx")
    Application.ScreenUpdating = False
    Do While Len(StrFile) > 0
        Set wb = Workbooks.Open(fpath & "\" & StrFile)
        Set sh = wb.Sheets(1)
        Set colB = sh.Range("B:B")
        On Error Resume Next
            sh.Cells(Func.Match(INTL, colB, 0), 3).CurrentRegion.Copy Orig.Cells(Rows.Count, 1).End(xlUp).Offset(1)
            sh.Cells(Func.Match(TRAX, colB, 0), 3).CurrentRegion.Copy Orig.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        On Error GoTo 0        
        wb.Close False
        StrFile = Dir
    Loop
End Sub