VBA copy values from multiple sheets based on multiple criteria into one worksheet

GEO81

New Member
Joined
Feb 9, 2022
Messages
12
Office Version
  1. 365
Platform
  1. Windows
Dears!

I have managed to modify a VBA code with the following result.
I can have multiple criteria for which my code search to different workbooks and if criteria meets then brings the required values to a new worksheet for each criteria value.
What I want to achieve is to bring all the values to one Worksheet Named Data (Workbook: Macros) .
So the first step is to replace the Row: Set wOut = Worksheets.Add with: Set wOut = Workbooks("Macros.xlsm").Sheets("Data").
However I'm not sure how to continue in order the values from my second criteria not to overwrite the previous ones.

Any assistance is more than welcome!

Code:
Sub SearchFolders()

    Dim fso As Object
    Dim fld As Object
    Dim strSearch As String
    Dim strPath As String
    Dim strFile As String
    Dim wOut As Worksheet
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim lRow As Long
    Dim rFound As Range
    Dim strFirstAddress As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False


    strPath = "C:\Users\cmkon\Desktop\CAMS"
    strSearch = InputBox("Enter Criteria")


Dim MyArray() As String, I As Variant


MyArray = Split(strSearch, ";")


For Each I In MyArray
  

    Set wOut = Worksheets.Add
    lRow = 1
    With wOut
        .Cells(lRow, 1) = "Workbook"
        .Cells(lRow, 2) = "Worksheet"
        .Cells(lRow, 3) = "Cell"
        .Cells(lRow, 4) = "Text in Cell"
        .Cells(lRow, 5) = "Instructions"
        .Cells(lRow, 6) = "WS#"
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.GetFolder(strPath)


        strFile = Dir(strPath & "\*.xls*") 'here defines which files to check
        Do While strFile <> ""
            Set wbk = Workbooks.Open _
              (Filename:=strPath & "\" & strFile, _
              UpdateLinks:=0, _
              ReadOnly:=True, _
              AddToMRU:=False)


            For Each wks In wbk.Worksheets
            Set rFound = wks.UsedRange.Find(I)
          
                        
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                End If
                Do
                    If rFound Is Nothing Then
                        Exit Do
                    Else
                        lRow = lRow + 1
                       .Cells(lRow, 1) = wbk.Name
                        .Cells(lRow, 2) = wks.Name
                        .Cells(lRow, 3) = rFound.Address
                        .Cells(lRow, 4) = rFound.Value
                       .Cells(lRow, 5) = rFound.Offset(, -1).Value
                       .Cells(lRow, 6) = lRow - 1
 
 
                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)
                Loop While strFirstAddress <> rFound.Address
            Next


            wbk.Close (False)
            strFile = Dir
        Loop
        .Columns("A:F").EntireColumn.AutoFit
    End With
    

 Next I

MsgBox "Done"

ExitHandler:
    Set wOut = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Exit Sub


ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
    
    
End Sub
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top