Excel - One macro for multiple row tasks

December 2016



Issue


I have two separate workbooks that I need to compare. Task at hand is I have to find specific text in workbook 2 (col A) and once found - I then have to copy the next two cells/rows (col B and C) and paste it in wkbook 1 (col B and C) for each individual row for the text found. The ones that are not found, can be left alone or blank.

Solution



You can use this:
Dim mySearchText As String 
Dim wb1, wb2 As Workbook 
Dim sh1, sh2 As Sheets 

Set wb1 = Workbooks("Book1") 
Set wb2 = Workbooks("Book2") 

Do While True 
mySearchText = InputBox("Enter Text to Search For. Enter blank to quit operation.", "Search for")

If (mySearchText = "") Then Exit Sub 


wb2.Activate 
wb2BRow = Cells(65536, 2).End(xlUp).Row 
wb2CRow = Cells(65536, 3).End(xlUp).Row 
If (wb2BRow > wb2CRow) Then 
wb2row = wb2BRow 
Else 
wb2row = wb2CRow 
End If 

If wb2row = 1 Then wb2row = 2 


wb1.Activate 

On Error Resume Next 

If ActiveSheet.AutoFilterMode Then 
Cells.Select 
Selection.AutoFilter 
End If 

If ActiveSheet.AutoFilterMode = False Then 
Rows(1).Select 
Selection.AutoFilter 
End If 

On Error GoTo 0 

Selection.AutoFilter Field:=1, Criteria1:="=" & mySearchText, Operator:=xlAnd 
Dim lastRow As Long 
lastRow = Cells(65536, 1).End(xlUp).Row 

If (lastRow > 1) Then 

Range(Cells(2, 2), Cells(lastRow, 3)).Select 
Selection.Copy 
wb2.Activate 
Cells(wb2row, 2).Select 
Selection.PasteSpecial 

wb2BRow = Cells(65536, 2).End(xlUp).Row 
wb2CRow = Cells(65536, 3).End(xlUp).Row 
If (wb2BRow > wb2CRow) Then 
wb2row = wb2BRow 
Else 
wb2row = wb2CRow 
End If 
wb2row = wb2row + 1 
End If 
Loop

Note


Thanks to rizvisa1 for this tip on the forum.

Related :

This document entitled « Excel - One macro for multiple row tasks » from CCM (ccm.net) is made available under the Creative Commons license. You can copy, modify copies of this page, under the conditions stipulated by the license, as this note appears clearly.