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

J

JeremyLongs

New Member
Joined
Nov 20, 2021
Messages
8
Office Version
  1. 2013
Platform
  1. Windows
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,

Code: 
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!
 
Sort by date Sort by votes
Try this:

VBA 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
    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
    Next Key
    
    If blankCellYN = "Y" Then
        MsgBox "Blank cell encountered in column 8, copying rows before blank cell only"
    End If
    
    ' 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
 
Upvote 0
Solution

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Alex Blakenburg said:
Try this:

VBA 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
    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
    Next Key
   
    If blankCellYN = "Y" Then
        MsgBox "Blank cell encountered in column 8, copying rows before blank cell only"
    End If
   
    ' 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
Click to expand...
Awesome everything works well now! Thank you so much Sir Alex for the effort and time offered!
 
Upvote 0
Alex Blakenburg said:
Try this:

VBA 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
    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
    Next Key
   
    If blankCellYN = "Y" Then
        MsgBox "Blank cell encountered in column 8, copying rows before blank cell only"
    End If
   
    ' 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
Click to expand...
Hi @Alex Blakenburg may I how to modify your code so that it will copy the values and format of sheet 1 column 2 to sheet 2 column 4

Thank you in Advance
 
Upvote 0
Also, I am trying to deconstruct your code, I am trying to separate the ("Goods") matches and the ("Services") Matches
with 3rd column result. The("Goods") match data will be sent to Column O and the ("Services") match data will be sent to Column J and will still follow the sequence of lngLastRowSht2 counter.

VBA 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
    Dim blankCellYN As String
    
    keywords = Array("Goods", "Services")
    
    Set sht1 = Worksheets(1)
    Set sht2 = Worksheets(2)
    
    lngLastRowSht1 = sht1.Cells(sht1.Rows.Count, 10).End(xlUp).Row
    lngLastRowSht2 = sht2.Cells(sht2.Rows.Count, 10).End(xlUp).Row
    
    arrSht1 = sht1.Range("B5:M" & lngLastRowSht1)
    ReDim arrSht2(1 To UBound(arrSht1), 1 To 3)
    counterSht2 = 8
    blankCellYN = "N"
    
    For Each Key In keywords
        For counterSht1 = 4 To lngLastRowSht1
            If arrSht1(counterSht1, 7) = Key Then
                counterSht2 = counterSht2 + 1
                arrSht2(counterSht2, 1) = arrSht1(counterSht1, 2)
                arrSht2(counterSht2, 2) = arrSht1(counterSht1, 3)
                arrSht2(counterSht2, 3) = arrSht1(counterSht1, 9)
            ElseIf arrSht1(counterSht1, 7) = "" Then
                blankCellYN = "Y"
                Exit For
            End If
        Next counterSht1
    Next Key
        
    If blankCellYN = "Y" Then
        MsgBox "Blank cell encountered in column 8, copying rows before blank cell only"
    End If
    
    ' Output in 2 steps per requirement to cater for future change in output columns
    sht2.Range("E" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 1)
    sht2.Range("D" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 2)
    sht2.Range("D" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 3)

See attached picture for desired sample output


Sheet1
GLBIS.png



Sheet2
B0P6u.png
 
Upvote 0
JeremyLongs said:
The("Goods") match data will be sent to Column O and the ("Services") match data will be sent to Column J and will still follow the sequence of lngLastRowSht2 counter.
Click to expand...

You really need to provide XL2BB data for your sheet1 and sheet2. Your pictures do not show rows and column references and Sheet2 7th & 8th column does not seem consistent with Column O & J.

Also the initial output and even the sheet 2 screen shot indicate that the 1st and 2nd outputs go to D & E respectively, your code has column output to E, D, D which means the 3rd overwrites the 2nd and it is all inconsistent with the output.
I also notice that you have the 6th column showing goods & services. I have mentioned that a few times and it is not being output by the macro so how is that being populated ?
To split the 9th column into 2 columns you will need to add not 1 but 2 elements in the column part of the array, so your 3 should be 4 and you will need to populate 3 or 4 based on whether they are good or services.

JeremyLongs said:
how to modify your code so that it will copy the values and format of sheet 1 column 2 to sheet 2 column 4
Click to expand...

Unless you want the whole column formatted the same, copying the format at the cell level is a total redesign. I am using arrays because it is faster but you can't use copy formats across using arrrays.
This needs to be specified up front as part of the initial requirements. You would need to start a new thread if you want that done.
 
Upvote 0
This should produce your output column (G) "6th" and your split into column J & O.

VBA Code: 
Sub CopyCells_OP_Mod()
    
    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")
    
'    XXX
'    Set sht1 = Worksheets(1)
'    Set sht2 = Worksheets(2)
    
    lngLastRowSht1 = sht1.Cells(sht1.Rows.Count, 10).End(xlUp).Row
    lngLastRowSht2 = sht2.Cells(sht2.Rows.Count, 10).End(xlUp).Row
    
    arrSht1 = sht1.Range("B5:M" & lngLastRowSht1)
    ReDim arrSht2(1 To UBound(arrSht1), 1 To 5)
    counterSht2 = 0                 ' XXX Changed
    blankCellYN = "N"
    
    For Each Key In keywords
        For counterSht1 = 1 To UBound(arrSht1)
            If arrSht1(counterSht1, 7) = Key Then
                counterSht2 = counterSht2 + 1
                arrSht2(counterSht2, 1) = arrSht1(counterSht1, 2)
                arrSht2(counterSht2, 2) = arrSht1(counterSht1, 5)
                arrSht2(counterSht2, 3) = arrSht1(counterSht1, 7)
                
                Select Case Key
                    Case "Goods"
                        arrSht2(counterSht2, 4) = arrSht1(counterSht1, 9)
                    Case "Services"
                        arrSht2(counterSht2, 5) = arrSht1(counterSht1, 9)
                    Case Else
                End Select
                
                
            ElseIf arrSht1(counterSht1, 7) = "" Then
                blankCellYN = "Y"
                Exit For
            End If
        Next counterSht1
    Next Key
        
    If blankCellYN = "Y" Then
        MsgBox "Blank cell encountered in column 8, copying rows before blank cell only"
    End If
    
    ' 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)
    sht2.Range("G" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 3)
    sht2.Range("J" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 4)
    sht2.Range("O" & lngLastRowSht2 + 1).Resize(counterSht2) = Application.Index(arrSht2, 0, 5)
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Copy /past cells by inputbox on sheet 2 to sheet1 using VBA
2
Replies
12
Views
501
DanteAmor
DanteAmor
Logit
  • Question Question
Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process
Replies
7
Views
326
Logit
Logit
I
  • Question Question
Searching multiple occurence of same keyword from text file and saving its output in different Excel worksheets
Replies
5
Views
337
myall_blues
myall_blues
N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
624
myall_blues
myall_blues
W
  • Solved
Looking For Tips To Improve My VBA
Replies
8
Views
198
who am i
W

Forum statistics

Threads
1,223,894
Messages
6,175,254
Members
452,623
Latest member
Techenthusiast

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