VBA to loop through a search and copy found data

qwerty · Mar 9, 2022

I have tried this on a couple of other forums with no luck:
https://stackoverflow.com/questions...373416?noredirect=1#comment126178842_71373416
https://www.mrexcel.com/board/threads/copy-data-based-on-cell-value.1198370/#post-5847707

Essentially I want to try is:
Sequentially search cells C51:C59 of wb2 where the sheets in wb2 are search sequentially using

Code:

For i = 3 To wb2.Worksheets.Count

of the opened wb2. Search would be looking for the work "HOTEL". "HOTEL" would be in a string of words.
If hotel is found the value of Column J, which is merged would then be copied to another workbook using

Code:

ThisWorkbook.Worksheets("JOB NUMBER").Range("A" & lr)

. I just cannot figure out a way to complete the search and sequentially enter the values in the cells.

CELL C51 = Hotel -> CELL J51 copied to "A" & lr

If there are multiple occurrences of hotel then the values would be summed prior to pasting them.

Code:

Sub IMPORT_DATA()
Application.ScreenUpdating = False
Application.Calculation = False
    Const FirstRow As Long = 4
    Const LastRow As Long = 9
    Const InitialFileName = "c:\"
    Dim FileName As String
    FileName = getFileName(InitialFileName)
    If Len(FileName) = 0 Then Exit Sub 'exits sub if no file name is selected
    Dim wb2 As Workbook
    Dim sh As Worksheets
    Dim lr As Long, i As Long, ls As Long, j As Long
    lr = FirstRow
    ls = LastRow


If Len(FileName) > 0 Then
Set wb2 = Workbooks.Open(FileName)
End If


    For i = 3 To wb2.Worksheets.Count 'Starts workbook search after rate sheets
        lr = lr + 1 'sets start row as 5
        With ThisWorkbook.Worksheets("JOB NUMBER").Range("A" & lr)    '<----- Change as required
            .Value = CStr(wb2.Worksheets(i).Name)
            .Offset(, 1).Value = wb2.Worksheets(i).Range("J61").MergeArea.Value
            .Offset(, 2).Value = wb2.Worksheets(i).Range("J27").MergeArea.Value
            .Offset(, 4).Value = wb2.Worksheets(i).Range("J39").MergeArea.Value
            .Offset(, 6).Value = wb2.Worksheets(i).Range("J50").MergeArea.Value
            .Offset(, 7).Value = wb2.Worksheets(i).Range("J60").MergeArea.Value
            '.Offset(, 8).Value = wb2.Worksheets(i).Range("B15").MergeArea.Value
            '.Offset(, 9).Value = wb2.Worksheets(i).Range("B16").MergeArea.Value
            '.Offset(, 10).Value = wb2.Worksheets(i).Range("B17").MergeArea.Value
            '.Offset(, 11).Value = wb2.Worksheets(i).Range("B18").MergeArea.Value
            '.Offset(, 12).Value = wb2.Worksheets(i).Range("B19").MergeArea.Value
            '.Offset(, 13).Value = wb2.Worksheets(i).Range("B20").MergeArea.Value
        End With
    Next i
    
  
'''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''Copy Crew Names Into Admin Page''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
With ThisWorkbook.Worksheets("ADMIN").Range("E2")
            .Value = wb2.Worksheets(3).Range("C12").MergeArea.Value
End With


'''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''Copy Job Number into tracker'''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
With ThisWorkbook.Worksheets("ADMIN").Range("E7")
            .Value = wb2.Worksheets(3).Range("J2").Value
End With
With ThisWorkbook.Worksheets("ADMIN").Range("E8")
            .Value = wb2.Worksheets(3).Range("K2").Value
End With


'''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''Copy client Name into Tracker'''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
With ThisWorkbook.Worksheets("JOB NUMBER").Range("B1")
            .Value = wb2.Worksheets(3).Range("C7").MergeArea.Value
End With


'''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''Copy Job Number into tracker'''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
With ThisWorkbook.Worksheets("JOB NUMBER").Range("D1")
            .Value = wb2.Worksheets(3).Range("H7").MergeArea.Value
End With




'Perform text to columns on ADMIN Sheet
    ThisWorkbook.Worksheets("ADMIN").Range("E2").TextToColumns , DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
                
    wb2.Close False
    Application.ScreenUpdating = True
    Application.Calculation = True
End Sub


Public Function getFileName(Optional InitialFileName As String) As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Select the a File"
        .InitialFileName = InitialFileName
        .Filters.Clear
        .Filters.Add "Excel files", "*.xls*"
        '.Filters.Add "All files", "*.csv"
        '.Filters.Add "All files", "*.*"


        If .Show = -1 Then
           getFileName = .SelectedItems(1)
        End If
        
    End With
End Function

VBA to loop through a search and copy found data

qwerty

New member