Copy data based on cell value

[Declanscully]

I was helped out with and subsequentially modified a bit. This works but I was wondering if there is a way to modify it so that the BOLDED section can be more dynamic.

Essentially I want to try is:
Sequentially search cells C15 of the opened wb2. Search would be looking for the letters OT. If no OT was found then the Cell B15 would be entered into Cell I5 ofwb1 (.Offset(, 8).Value = wb2.Worksheets(i).Range("B15").MergeArea.Value). If OT was found, the value would be entered into Cell I6 of wb1.

Then it would search Cell B16 etc. until it hits an empty cell at which point it would move on to the next worksheet as it currently does.

I think I can figure out a way to brute force it, but was wondering if there is an elegant solution.

Sub IMPORT_DATA()
Application.ScreenUpdating = False
Application.Calculation = False
    Const FirstRow As Long = 4
    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
    lr = FirstRow

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
        [B].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[/B]
            
            End With
    Next i
    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

 

[Joe4]

Duplicate to: Copy data based on cell value

In future, please do not post the same question multiple times. Per Forum Rules (#12), posts of a duplicate nature will be locked or deleted.

In relation to your question here, I have closed this thread so please continue in the linked thread. If you do not receive a response, you can "bump" it by replying to it yourself, though we advise you to wait 24 hours before doing so, and not to bump a thread more than once a day.