Looping through Worksheets in Workbook while looking for specific text

[MatthewLane412]

Working on a macro that will loop through Workbooks in a folder. Within each workbook it will loop through all the sheets looking for a specific string of text. In this case "*Labor*". My sample workbooks, has 3 sheets with "Labor" in the WS name). Once it finds a match the macro will copy and paste the information into the master workbook and append the data at the bottom.

Looping through Workbooks works great when specifying a sheet name. The code isn't working when searching through the sheet names for a key string. My Master sheet has the same data pasted into it 10's of times from the first sheet with "*Labor*" in the name for both workbooks when running the macro.

All help is much appreciated. Thank you

Sub CopyRangeToMaster

Application.ScreenUpdating = False
    Dim WS As Worksheet
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Dim finRow As String
    Dim LastRow2 As Long
    Dim LastRow3 As Long
    Dim strExtension As String
    Const strPath As String = "C:\Users\E086365\Desktop\Matt Testing VBA\IndividualBusinessCases\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
        For Each WS In ActiveWorkbook.Worksheets
        If ActiveSheet.Name Like "*Labor*" Then
            LastRow = ActiveSheet.Range("CE200000").End(xlUp).Row
            LastRow2 = ActiveSheet.Range("B" & LastRow - 5).End(xlUp).Row
            finRow = wkbDest.Sheets("Labor_Master").Range("B200000").End(xlUp).Row
            ActiveSheet.Range("B7:DE" & LastRow2).Copy
            wkbDest.Sheets("Labor_Master").Range("B" & finRow + 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            End If
            Next WS
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

We needed to change activesheet to WS, try this:

Sub CopyRangeToMaster()

  Application.ScreenUpdating = False
    Dim WS As Worksheet
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Dim finRow As String
    Dim LastRow2 As Long
    Dim LastRow3 As Long
    Dim strExtension As String
    Const strPath As String = "C:\Users\E086365\Desktop\Matt Testing VBA\IndividualBusinessCases\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
          For Each WS In ActiveWorkbook.Worksheets
            If WS.Name Like "*Labor*" Then
              LastRow = WS.Range("CE200000").End(xlUp).Row
              LastRow2 = WS.Range("B" & LastRow - 5).End(xlUp).Row
              finRow = wkbDest.Sheets("Labor_Master").Range("B" & Rows.Count).End(xlUp).Row
              WS.Range("B7:DE" & LastRow2).Copy
              wkbDest.Sheets("Labor_Master").Range("B" & finRow + 1).PasteSpecial xlPasteValues
              Application.CutCopyMode = False
            End If
          Next WS
          .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
  Application.ScreenUpdating = True
End Sub

 

[MatthewLane412]

Trying now.

 

[MatthewLane412]

Worked perfect. Thank you for your help!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.