Adding another search function into an existing search loop

ChrisRamsden

ChrisRamsden

New Member
Joined
Sep 26, 2018
Messages
24
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.

Rich (BB code): 
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
Rich (BB code): 
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
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
Something like this???
Code: 
If Left(cell.Value, 4) = "826/" Then
As a general comment, activation and selection are rarely needed and slow things down. Also, your use of copy and paste seems unnecessary. For example, the following code...
Code: 
Wb2.Activate
ActiveCell.Offset(1, 5).Copy
ThisWorkbook.Activate
Sheets("TR1799").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
could be....
Code: 
ThisWorkbook.Sheets("TR1799").Range("D" & Rows.Count).End(xlUp).Offset(1) = Cell.Offset(1,5)
HTH. Dave
 
Upvote 0
Hi Dave,

Thanks for the suggestion. Where would you advise i put the additional search criteria, as i only want it to search for 2 pieces of data and not the other 7 (as they are relatively constant within the data set?)

Also thank you for the clean up suggestion as well, i will try this tomorrow when i work on it again and check i get the same results.

Thank you
 
Upvote 0
Hi Everyone,

So i have found that the problem is when the macro is converting text to columns. The company name in the data is moving the other data out of position due to the maority on company names having no spaces (the conversion to columns is based on spaces.)

How can i adapt this bit of code so that it only converts to column based on more than 1 space?
Code: 
         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

P.S Dave your clean up of my formula works great - thank you for that :)
 
Upvote 0
U R Welcome however....
Code: 
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
could be...
Code: 
Wb2.Columns("A:A").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
Sorry I don't know anything re. text to columns. :) Dave
 
Upvote 0
Thanks again Dave.

So heres my latest update:

I nearly have the code working as i want it to. Had to through a few work arounds in but hey it nearly works so im fine with that. In the below code i have highlightd the section in purple where the original paste takes place. In red i have highlighted what i want to change:

Can this section paste based off the original paste rather than using xlup, as this is still throwing some of the data slightly as there are ocassional blanks?

Rich (BB code): 
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

   
'Open file selection panel, convert selected files into excel, split data from one cell to single cells and tidy it up.
   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
             With CreateObject("VBScript.RegExp")
        .Pattern = " {2,}"
        .Global = True
        For Each cell In Intersect(Selection.Cells, ActiveSheet.UsedRange)
            If Not cell.HasFormula Then cell.Value = .Replace(cell.Text, "!")
        Next cell
    End With
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    For Each cell In Range("A1:A" & lRow)
    cell.Offset(0, 0) = VBA.LTrim(cell.Value)
    Next cell
    
            Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="!", 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 loops through the data until all card numbers have been found.
         lRow = Range("A" & Rows.Count).End(xlUp).Row
         For Each cell In Range("A1:A" & 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
                  ThisWorkbook.Sheets("TR1799").Range("B" & Rows.Count).End(xlUp).Offset(1) = cell.Offset(0, 1)
                  ThisWorkbook.Sheets("TR1799").Range("C" & Rows.Count).End(xlUp).Offset(1) = cell.Offset(1, 0)
                  ThisWorkbook.Sheets("TR1799").Range("D" & Rows.Count).End(xlUp).Offset(1) = cell.Offset(1, 2)
                  ThisWorkbook.Sheets("TR1799").Range("E" & Rows.Count).End(xlUp).Offset(1) = cell.Offset(1, 2)
                  ThisWorkbook.Sheets("TR1799").Range("F" & Rows.Count).End(xlUp).Offset(1) = cell.Offset(2, 1)
                  ThisWorkbook.Sheets("TR1799").Range("G" & Rows.Count).End(xlUp).Offset(1) = cell.Offset(2, 4)
                  ThisWorkbook.Sheets("TR1799").Range("H" & Rows.Count).End(xlUp).Offset(1) = cell.Offset(2, 5)
                  ThisWorkbook.Sheets("TR1799").Range("I" & Rows.Count).End(xlUp).Offset(1) = cell.Offset(2, 12)
                  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

I think this will finally resolve my issue and give me a fully working macro. Any help would be greatly appreciated.

Thank you
 
Upvote 0
Not real sure where U want the results? Trial this...
Code: 
'Select data and copy and paste into spreadsheet. This loops through the data until all card numbers have been found.
         lrow = Range("A" & Rows.Count).End(xlUp).Row
         For Each cell In Range("A1:A" & lrow)
            If Not IsError(cell) Or cell = vbNullString Then
               If Left(cell.Value, 1) = "4" Then
                  ThisWorkbook.Sheets("TR1799").Range("A" & lrow + 1) = cell.Value
                  ThisWorkbook.Sheets("TR1799").Range("B" & lrow + 1) = cell.Offset(0, 1)
                  ThisWorkbook.Sheets("TR1799").Range("C" & lrow + 1) = cell.Offset(1, 0)
                  ThisWorkbook.Sheets("TR1799").Range("D" & lrow + 1) = cell.Offset(1, 2)
                  ThisWorkbook.Sheets("TR1799").Range("E" & lrow + 1) = cell.Offset(1, 2)
                  ThisWorkbook.Sheets("TR1799").Range("F" & lrow + 1) = cell.Offset(2, 1)
                  ThisWorkbook.Sheets("TR1799").Range("G" & lrow + 1) = cell.Offset(2, 4)
                  ThisWorkbook.Sheets("TR1799").Range("H" & lrow + 1) = cell.Offset(2, 5)
                  ThisWorkbook.Sheets("TR1799").Range("I" & lrow + 1) = cell.Offset(2, 12)
               End If
            End If
         Next cell
HTH. Dave
 
Upvote 0
Hi Dave,

Thanks for replying. I have tried the amendment but unfortunately it overwrites the same row each time it passes through the cycle. Its the right principle but each time the loop goes around i need the next found set of data to go on the next row. When i ran the report there should be about 30 lines of data and with this amendment there is only 1.

Is there something that can be added to your suggestion which would drop 1 row each time the loop criteria is met?

Thank you
 
Upvote 0
This should do it...
Code: 
'Select data and copy and paste into spreadsheet. This loops through the data until all card numbers have been found.
         Dim Cnt As Integer
         Cnt = 0
         lrow = Range("A" & Rows.Count).End(xlUp).Row
         For Each cell In Range("A1:A" & lrow)
            If Not IsError(cell) Or cell <> vbNullString Then
               If Left(cell.Value, 1) = "4" Then
                  Cnt = Cnt + 1
                  ThisWorkbook.Sheets("TR1799").Range("A" & lrow + Cnt) = cell.Value
                  ThisWorkbook.Sheets("TR1799").Range("B" & lrow + Cnt) = cell.Offset(0, 1)
                  ThisWorkbook.Sheets("TR1799").Range("C" & lrow + Cnt) = cell.Offset(1, 0)
                  ThisWorkbook.Sheets("TR1799").Range("D" & lrow + Cnt) = cell.Offset(1, 2)
                  ThisWorkbook.Sheets("TR1799").Range("E" & lrow + Cnt) = cell.Offset(1, 2)
                  ThisWorkbook.Sheets("TR1799").Range("F" & lrow + Cnt) = cell.Offset(2, 1)
                  ThisWorkbook.Sheets("TR1799").Range("G" & lrow + Cnt) = cell.Offset(2, 4)
                  ThisWorkbook.Sheets("TR1799").Range("H" & lrow + Cnt) = cell.Offset(2, 5)
                  ThisWorkbook.Sheets("TR1799").Range("I" & lrow + Cnt) = cell.Offset(2, 12)
               End If
            End If
         Next cell
Dave
ps. changed the blank cell logic
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Copy listobject table from one worksheet to another workbook
Replies
2
Views
955
Alex Blakenburg
A
T
  • Question
This is so slow I have to run it overnight
Replies
4
Views
243
kevin9999
K
A
  • Solved
copy paste from one worksheet to other but in different columns
2
Replies
18
Views
734
Joe4
Joe4
G
  • Question
Copying and pasting between two workbooks
Replies
1
Views
512
rlv01
R
E
  • Question
Filtering values from data source and pasting it into a second workbook
2
Replies
17
Views
913
kevin9999
K

Forum statistics

Threads
1,215,059
Messages
6,122,918
Members
449,093
Latest member
dbomb1414

Share this page

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