VBA Macro search match twice 2 keywords same column and copy result to another sheet

[JeremyLongs]

Hi internet peeps. I am stuck i don't know what code to use so i can search the same column twice for 2 different keyword and then copy data from the same row to another spreadsheet in sequence from a start cell. for details here's what i am trying to do

1. Limit the search within a range of the worksheet (ex. Sheet 1 B1:N:200)
2. Search the 8th column (I) of the limit range Sheet1 for keyword ("Goods")
3. Copy the data found in the 2nd (C) and 5th column (F) of same row where instance "Goods " is found
4. Paste Value of Sheet 1 - column 2 to Sheet2 - Column 3 (no format values only), and Sheet 1 column 5 to Sheet 2 Column4 (with format and values) on a specific starting point (ex. Sheet 2 - B3) Next Match Result will be Sheet 2 - B4 and so on
5.Search AGAIN the 8th column of Sheet1 for keyword ("Services") starting from the top (B1:N1)
6.Copy the data found in the 2nd (C) and 5th column (F) of same row where instance "Services" is found
7. Paste Value of Sheet 1 - column 2 to Sheet2 - Column 3 (no format values only), and Sheet 1 column 5 to Sheet 2 Column4 (with format and values) to next row after the last PASTE from "Goods" was done. (ex last row match paste was C35 and D35 new found value should be paste in C36 a D36)

I hope i have conveyed what i need clearly

I am trying to work on this code that i found here but i just don't get how to reset the counter do i need to reset?, how to insert the 2nd search loop for services., how to paste on specific cell in sheet2, how to follow the last row for "services" paste,

Sub CopyCells()

Dim lngLastRowSht1 As Long
Dim lngLastRowSht2 As Long
Dim counterSht1 As Long
Dim counterSht2 As Long

With Worksheets(1)
    lngLastRowSht1 = .Cells(.Rows.Count, 8).End(xlUp).Row
    lngLastRowSht2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, 5).End(xlUp).Row
        For counterSht1 = 1 To lngLastRowSht1
            For counterSht2 = 1 To lngLastRowSht2
                If Sheets(1).Range("" & (counterSht1)).Value = "Goods" Then
                    Sheets(2).Range("B" & (counterSht2), "D" & (counterSht2)).Value = Sheets(1).Range("C" & counterSht1, "D" & counterSht1).Value
                                    End If
            Next counterSht2
        Next counterSht1
        
End With
End Sub

Advance THANK YOU Internet peeps!

 

[Alex Blakenburg]

Some requirements & speed clarifications.

• Is the keyword an exact match in column 8 or is it part of a longer text string ?
• You are not outputting column 8 so how will you know which lines are services and which are goods ?
• Do services and goods need to be output as a block or can they be output as they are found in the input row order ?
• How many rows in original data (speed design consideration)
• Will the output columns always be next to each other - currently 3 & 4 - ie can be written out as a block of data.

PS: You could use Power Query to do this if you didn't specifically want to use VBA.

 

[JeremyLongs]

Hi Alex Thanks for replying

1. yes exact match spelling wise but not to rigid with case sensitivity2. It will be written in column 8 if its goods or services
3. Output can be done as found in the input row order
4. just less than 200 rows of data at most
5. current need will be next to each other but future need might e 3&6 for example

Sheet 1

Sheet2

Hope this helped clarify my request

 

[Alex Blakenburg]

OK I will knock something up.
I am still concerned that your sample output does not have a column for Goods and Services.
I also don't understand how you are going to populate the other columns on the same rows that are going to be populated by the macro.

 

[Alex Blakenburg]

If your volumes get bigger it is likely that using autofilter will be faster but in the meantime this is more along the lines of your original code.

Sub CopyCells()
   
    Dim lngLastRowSht1 As Long
    Dim lngLastRowSht2 As Long
    Dim counterSht1 As Long
    Dim counterSht2 As Long
   
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim keywords() As Variant
    Dim Key As Variant
    Dim arrSht1 As Variant
    Dim arrSht2() As Variant
   
    keywords = Array("Goods", "Services")
   
    Set sht1 = Worksheets("Sheet1")
    Set sht2 = Worksheets("Sheet2")
   
    lngLastRowSht1 = sht1.Cells(sht1.Rows.Count, 8).End(xlUp).Row
    lngLastRowSht2 = sht2.Cells(sht2.Rows.Count, 5).End(xlUp).Row
   
    arrSht1 = sht1.Range("B2:M" & lngLastRowSht1)
    ReDim arrSht2(1 To UBound(arrSht1), 1 To 2)
    counterSht2 = 0
   
    For Each Key In keywords
        For counterSht1 = 1 To lngLastRowSht1 - 1
            If arrSht1(counterSht1, 8) = Key Then
                counterSht2 = counterSht2 + 1
                arrSht2(counterSht2, 1) = arrSht1(counterSht1, 2)
                arrSht2(counterSht2, 2) = arrSht1(counterSht1, 5)
            End If
        Next counterSht1
    Next Key
   
    ' Output in 2 steps per requirement to cater for future change in output columns
    sht2.Range("D" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 1)
    sht2.Range("E" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 2)


End Sub

 

[JeremyLongs]

If your volumes get bigger it is likely that using autofilter will be faster but in the meantime this is more along the lines of your original code.

Sub CopyCells()
  
    Dim lngLastRowSht1 As Long
    Dim lngLastRowSht2 As Long
    Dim counterSht1 As Long
    Dim counterSht2 As Long
  
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim keywords() As Variant
    Dim Key As Variant
    Dim arrSht1 As Variant
    Dim arrSht2() As Variant
  
    keywords = Array("Goods", "Services")
  
    Set sht1 = Worksheets("Sheet1")
    Set sht2 = Worksheets("Sheet2")
  
    lngLastRowSht1 = sht1.Cells(sht1.Rows.Count, 8).End(xlUp).Row
    lngLastRowSht2 = sht2.Cells(sht2.Rows.Count, 5).End(xlUp).Row
  
    arrSht1 = sht1.Range("B2:M" & lngLastRowSht1)
    ReDim arrSht2(1 To UBound(arrSht1), 1 To 2)
    counterSht2 = 0
  
    For Each Key In keywords
        For counterSht1 = 1 To lngLastRowSht1 - 1
            If arrSht1(counterSht1, 8) = Key Then
                counterSht2 = counterSht2 + 1
                arrSht2(counterSht2, 1) = arrSht1(counterSht1, 2)
                arrSht2(counterSht2, 2) = arrSht1(counterSht1, 5)
            End If
        Next counterSht1
    Next Key
  
    ' Output in 2 steps per requirement to cater for future change in output columns
    sht2.Range("D" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 1)
    sht2.Range("E" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 2)


End Sub

Thank You for taking the time to make this Code, It works perfectly if i may just add how to make the macro stop if it encounters a blank cell while searching for match in column 8 and a message box where the blank cell was located. Also for the other data column

 

[Alex Blakenburg]

Thank You for taking the time to make this Code, It works perfectly if i may just add how to make the macro stop if it encounters a blank cell while searching for match in column 8 and a message box where the blank cell was located. Also for the other data column

Are you saying you want to check column 8 for a blank cell and terminate ?
In terms of data columns, do you want to also check columns 2 and 5 for blanks ? If so do you want this checked only if column 8 is a match or for any row ?

This is a terribly inefficient way to check for blanks. You are better off running a filter for blanks first and sort out any data issues. Finding blanks one at a time is going to get really annoying really quickly.

 

[JeremyLongs]

Are you saying you want to check column 8 for a blank cell and terminate ?
In terms of data columns, do you want to also check columns 2 and 5 for blanks ? If so do you want this checked only if column 8 is a match or for any row ?

This is a terribly inefficient way to check for blanks. You are better off running a filter for blanks first and sort out any data issues. Finding blanks one at a time is going to get really annoying really quickly.

Ohhh thats a good point instead of searching one by one for blank cells.

with your advice i will just need

1. to check column 8 for blank cell and terminate only upon encounter with blank cell midway of copy pasting process. I need it to cut off from another set of data
2. a filter as suggested to check for blanks for column 2 and 5 only when matched with column 8, if advisable to implement. if not then #1 is the only thing i need.
P.S i tried reading how to do this and inserting dowhile/ do until to your code but it can't get it to work

Thank you again

 

[Alex Blakenburg]

This will exit when column 8 is blank before reaching the actual last row.
It doesn't really make sense to add a filter for other blank cells into this code.
If you want to pursue that perhaps clarify what you want to do and post it as a separate thread.

Sub CopyCells()
    
    Dim lngLastRowSht1 As Long
    Dim lngLastRowSht2 As Long
    Dim counterSht1 As Long
    Dim counterSht2 As Long
    
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim keywords() As Variant
    Dim Key As Variant
    Dim arrSht1 As Variant
    Dim arrSht2() As Variant
    Dim blankCellYN As String
    
    keywords = Array("Goods", "Services")
    
    Set sht1 = Worksheets("Sheet1")
    Set sht2 = Worksheets("Sheet2")
    
    lngLastRowSht1 = sht1.Cells(sht1.Rows.Count, 8).End(xlUp).Row
    lngLastRowSht2 = sht2.Cells(sht2.Rows.Count, 5).End(xlUp).Row
    
    arrSht1 = sht1.Range("B2:M" & lngLastRowSht1)
    ReDim arrSht2(1 To UBound(arrSht1), 1 To 2)
    counterSht2 = 0
    blankCellYN = "N"
    
    For Each Key In keywords
        For counterSht1 = 1 To lngLastRowSht1 - 1
            If arrSht1(counterSht1, 8) = Key Then
                counterSht2 = counterSht2 + 1
                arrSht2(counterSht2, 1) = arrSht1(counterSht1, 2)
                arrSht2(counterSht2, 2) = arrSht1(counterSht1, 5)
            ElseIf arrSht1(counterSht1, 8) = "" Then
                blankCellYN = "Y"
                Exit For
            End If
        Next counterSht1
        If blankCellYN = "Y" Then
            MsgBox "Blank cell encountered in column 8, exiting loop"
            Exit For
        End If
    Next Key
    
    ' Output in 2 steps per requirement to cater for future change in output columns
    sht2.Range("D" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 1)
    sht2.Range("E" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 2)

End Sub

 

[JeremyLongs]

Hello again @Alex Blakenburg . I tried your modification the macro detects the existence of blank cell, however it does not populate the result before it reached the blank cell. So no data is transferred from Sheet1 to Sheet2.

Is it possible to paste results from good matches then exit only upon encounter of the blank cell.