Adding another search function into an existing search loop

[ChrisRamsden]

Hi Everyone,

I posted about this code a few weeks ago and got some great responses and assistance which helped me crack my problem. Upon duplicating this code for a similar report i have come stuck again with another issue, so i am asking your legends for some help again.

In the below code i am struggling to pull out 2 pieces of information as they are not consistent within the data set. I think the solution is to add an additional search function in the middle to find a reference point and work from there. The reference point would be 826/ as the 2 pieces of data i need are adjacent to that reference point. In the code i have highlighted the section where i am trying to get the information in red.

Sub GetData1799()
Application.ScreenUpdating = False
   Dim lRow As Long
   Dim cell As Range
   Dim myFile As Variant
   Dim Wb2 As Workbook
   Dim Fd As Object
   Dim x As Long

   
   With Application.FileDialog(3)
      .InitialFileName = "C:\Documents and Settings\UPN0OV\Desktop\VISA MACRO"
      .Show
      For Each myFile In .SelectedItems
         Set Wb2 = Workbooks.Open(myFile)
         
         Wb2.Activate
         Columns("A:A").Select
         Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
            Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
            )), TrailingMinusNumbers:=True
         
         'Select data and copy and paste into spreadsheet. This contains a loop through the data
         
         lRow = Range("B" & Rows.Count).End(xlUp).Row
         For Each cell In Range("B1:B" & lRow)
            If Not IsError(cell) Then
               If Left(cell.Value, 1) = "4" Then
                  cell.Select
                  ActiveCell.Copy
                  ThisWorkbook.Activate
                  Sheets("TR1799").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(0, 1).Copy
                  ThisWorkbook.Activate
                  Sheets("TR1799").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(1, 0).Copy
                  ThisWorkbook.Activate
                  Sheets("TR1799").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(1, 5).Copy
                  ThisWorkbook.Activate
                  Sheets("TR1799").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(1, 6).Copy
                  ThisWorkbook.Activate
                  Sheets("TR1799").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(2, 0).Copy
                  ThisWorkbook.Activate
                  Sheets("TR1799").Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(2, 4).Copy
                  ThisWorkbook.Activate
                  Sheets("TR1799").Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(2, 5).Copy
                  ThisWorkbook.Activate
                  Sheets("TR1799").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
                  ActiveCell.Offset(2, 12).Copy
                  ThisWorkbook.Activate
                  Sheets("TR1799").Range("I" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                  Wb2.Activate
               End If
            End If
         Next cell
         Wb2.Close False
      Next myFile
   End With
   
   
    'Clear out incorrect data
   ThisWorkbook.Activate
lRow = Range("A65536").End(xlUp).Row
For x = lRow To 2 Step -1
If Len(Cells(x, 1)) <= 6 Then
Rows(x).EntireRow.Delete
End If
Next x
   
   
   'Reactivate screen updating
   Application.ScreenUpdating = True
   Application.CutCopyMode = False
   
   'Report out the Macro has finished
   MsgBox "Macro Complete"
   
End Sub

Is it possible to use a simliar search function that i am already using

If Left(cell.Value, 1) = "4" Then

as i have tried and am unable to get it to work.

Apologies in advance if i haven't made this perfectly clear, im happy to go into more detail if needed.

Thank you

 

[NdNoviceHlp]

You are Welcome. Thanks for posting your outcome. Dave