VBA Code for Macro - Search sheet for keywords and paste rows to new sheet

J

JoeDelcambre

New Member
Joined
Feb 20, 2022
Messages
16
Office Version
  1. 365
Platform
  1. Windows
Hello,

I'm trying to write a VBA macro to search a worksheet for several different keywords, copy those rows and paste rows (including column titles) onto a new sheet.

My goal is to find these words:
"Windows 7"
"windows 7"
"Win 7"
"win 7"
"XP"
"Win XP"
"win XP"
"windows XP"

The issue I'm running into is some of the keywords I'm looking for are not the only words within a cell. For example, a cell may have "74BBN win 7 TTP77". My current macros are not locating and pasting those rows over to the new sheet, but only the cells with only the exact phrase "win 7" for example.

The example I'm posting is a dummy worksheet I created for testing purposes. The actual one I'm working with has about 44,000 rows, and 50 or so columns. Any and all help is greatly appreciated.


macro tests2.xlsm
ABCDEFGHIJKLMN
1IDMust_PayFundedAgencyDirectorate_IDDivision_IDAcq_PackageOS Amount_Paid Amount_Owed Date_UpdatedStart_DateEnd_DateUpdated_By
2ABC568yesyesUSMCJ6IODUSMC-Package 789vista$ 4,000.00$ 10,000.0012/25/20212/5/20202/1/2022John Smith
3SDJ4478yesnoUSMCJ6CSDUSMC-Package 789XP$ 2,000.00$ 12,000.0011/15/20212/5/20202/2/2022Jane Doe
4LIU9898noyesUSAJ3CSDUSA-Package 3398JTTP4 Windows 7 HWLM$ 3,500.00$ 6,500.003/2/20213/1/20212/3/2022John Doe
5HBR5454yesnoUSAJ3SDDUSA-Package 3398JWin 10$ 2,500.00$ 7,500.006/15/20214/1/20212/4/2022Jane Smith
6NHRI2347yesyesUSNJ2EODUSN-Package 923Windows 10$ 1,200.00$ 10,000.001/22/20225/5/20202/5/2022Jane Smith
7NCUR2458noyesUSCGJ6CIOUSCG-Package 3287Vista$ 6,500.00$ 8,000.001/6/20229/4/20202/6/2022Jane Smith
8LKJ2147noyesUSAFJ3CSDUSAF-Package 776534Win XP$ 2,100.00$ 3,500.007/25/20217/5/20212/7/2022Jane Smith
9POI6698yesnoUSAJ4IODUSA-Package 3398Jwin xp$ 9,800.00$ 12,000.009/2/20214/16/20202/8/2022Jane Smith
10ABCS987nonoUSAFJ1SDDUSAF-Package 776534TTP4 Windows 7 HWLM$ 7,400.00$ 8,000.006/6/20213/1/20212/9/2022Joe Doe
11SMN3298noyesUSSFS4CSDUSSF-Package 2312Windows 7$ 6,500.00$ 9,500.009/22/20217/5/20212/10/2022Joe Doe
12LED8852nonoUSSFS4IODUSSF-Package 2312Windows 10$ 3,500.00$ 3,500.0011/2/20216/7/20202/11/2022John Smith
13LMN326yesyesUSCGS2CSDUSCG-Package 3287Windows XP$ 2,100.00$ 2,500.007/9/20213/1/20212/12/2022John Doe
14WDC589noyesUSNS6CIOUSN-Package 923Win 7$ 1,750.00$ 8,700.002/1/202211/9/20202/13/2022Jane Doe
15VFD365yesyesUSNS6CIOUSN-Package 923Win xp$ 630.00$ 6,500.003/6/20213/25/20202/14/2022Jane Smith
16CVF127yesyesUSMCS3CIOUSMC-Package 78974BBN win 7 TTP77$ 2,500.00$ 3,500.0012/1/20211/6/20212/15/2022Jane Smith
17CVRF9863yesnoUSNJ2SDDUSN-Package 923windows 7$ 7,800.00$ 7,800.002/2/20229/7/20202/16/2022Jane Smith
18MMLK145nonoUSMCJ4IODUSMC-Package 789windows 10$ 9,800.00$ 9,800.003/8/20213/19/20212/17/2022John Doe
19EWD441yesyesUSAFS4CSDUSAF-Package 776534windows XP$ 1,200.00$ 4,500.008/5/20217/7/20202/18/2022John Doe
20RRB2285nonoUSAFS5CSDUSAF-Package 776534Windows 7$ 3,200.00$ 4,500.009/5/20219/3/20202/19/2022John Doe
21ABC568yesorangeabcJ6xyzUSMC-Package 789vista$ 4,000.00$ 10,000.0012/25/20212/5/20202/1/2022John Smith
22SDJ4478yesorangeUSMCJ6CSDUSMC-Package 789XP$ 2,000.00$ 12,000.0011/15/20212/5/20202/2/2022Jane Doe
23LIU9898noyesUSAJ3xyzUSA-Package 3398JWindows 7$ 3,500.00$ 6,500.003/2/20213/1/20212/3/2022John Doe
24HBR5454yesnoabcJ3CSDUSA-Package 3398JWin 10$ 2,500.00$ 7,500.006/15/20214/1/20212/4/2022Jane Smith
25NHRI2347yesbananaUSNJ2EODUSN-Package 923Windows 10$ 1,200.00$ 10,000.001/22/20225/5/20202/5/2022Jane Smith
26NCUR2458noyesabcJ6xyzUSCG-Package 3287Vista$ 6,500.00$ 8,000.001/6/20229/4/20202/6/2022Jane Smith
27LKJ2147noyesUSAFJ3CSDUSAF-Package 776534Win XP$ 2,100.00$ 3,500.007/25/20217/5/20212/7/2022Jane Smith
28POI6698yesappleUSAJ4IODUSA-Package 3398Jwin xp$ 9,800.00$ 12,000.009/2/20214/16/20202/8/2022Jane Smith
29ABCS987nonoabcJ1SDDUSAF-Package 776534Windows 7$ 7,400.00$ 8,000.006/6/20213/1/20212/9/2022Joe Doe
30SMN3298noyesUSSFS4CSDUSSF-Package 2312Windows 7$ 6,500.00$ 9,500.009/22/20217/5/20212/10/2022Joe Doe
31LED8852nonodefS4xyzUSSF-Package 2312Windows 10$ 3,500.00$ 3,500.0011/2/20216/7/20202/11/2022John Smith
32LMN326yesappleabcS2CSDUSCG-Package 3287Windows XP$ 2,100.00$ 2,500.007/9/20213/1/20212/12/2022John Doe
33WDC589noUSNS6defUSN-Package 92374BBN Win 7 TTP77$ 1,750.00$ 8,700.002/1/202211/9/20202/13/2022Jane Doe
34VFD365yesyesUSNS6xyzUSN-Package 923Win xp$ 630.00$ 6,500.003/6/20213/25/20202/14/2022Jane Smith
35CVF127yesappleabcS3xyzUSMC-Package 789win 7$ 2,500.00$ 3,500.0012/1/20211/6/20212/15/2022Jane Smith
36CVRF9863yesnoUSNJ2SDDUSN-Package 923windows 7$ 7,800.00$ 7,800.002/2/20229/7/20202/16/2022Jane Smith
37MMLK145nonoabcJ4IODUSMC-Package 789windows 10$ 9,800.00$ 9,800.003/8/20213/19/20212/17/2022John Doe
38EWD441yesyesUSAFS4CSDUSAF-Package 776534windows XP$ 1,200.00$ 4,500.008/5/20217/7/20202/18/2022John Doe
39RRB2285nonodefS5CSDUSAF-Package 776534Windows 7$ 3,200.00$ 4,500.009/5/20219/3/20202/19/2022John Doe
Sheet1
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
johnnyL said:
You should post the code you are trying right now.
Click to expand...
Here is the most recent code I used for the test worksheet I posted. This code (or a similar variation) actually worked on the test worksheet, but did not work on the real-world worksheets/data I'm working on. Eventually, I was able to modify the macro to work on my real-world worksheets, but the results pasted all 44,000 rows from the worksheet. So, I may try to start from scratch because I am getting lost the further I fall down the rabbit hole.

Here's the code:

Option Explicit
Sub MacroTest1()
Dim ws1 As Worksheet, ws2 As Worksheet, ar
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

ar = Array("*Win* 7*", "*XP*")

With ws1.Cells(1, 1).CurrentRegion
.AutoFilter 8, Array(ar), 7
.Copy ws2.Cells(11, 1)
.AutoFilter
End With

ws2.Cells(11, 1).AutoFilter
End Sub

Thanks again for your assistance.
 
Upvote 0
JoeDelcambre said:
Here is the most recent code I used for the test worksheet I posted. This code (or a similar variation) actually worked on the test worksheet, but did not work on the real-world worksheets/data I'm working on. Eventually, I was able to modify the macro to work on my real-world worksheets, but the results pasted all 44,000 rows from the worksheet. So, I may try to start from scratch because I am getting lost the further I fall down the rabbit hole.

Here's the code:

Option Explicit
Sub MacroTest1()
Dim ws1 As Worksheet, ws2 As Worksheet, ar
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

ar = Array("*Win* 7*", "*XP*")

With ws1.Cells(1, 1).CurrentRegion
.AutoFilter 8, Array(ar), 7
.Copy ws2.Cells(11, 1)
.AutoFilter
End With

ws2.Cells(11, 1).AutoFilter
End Sub

Thanks again for your assistance.
Click to expand...
tested it mate with your dummy data and it works well copied the "target" keyword
I manually counted the would be result (26 records) and it successfully copied and pasted it on sheet2...
 
Upvote 0
Below code will create a new sheet with filterred rows
VBA Code: 
Option Explicit
Sub copy()
Application.ScreenUpdating = False
Dim Lr&, Lrb&, i&, j&, k&, cell As Range, cri, arr()
ActiveWorkbook.Worksheets("Sheet1").copy after:=Sheets(Sheets.Count)
Application.CutCopyMode = False
cri = Array("win 7", "windows 7", "xp") ' add more criterias if needed
With ActiveSheet
    Lr = .Cells(Rows.Count, "H").End(xlUp).Row
    ReDim arr(1 To Lr, 1 To 1)
    For i = 2 To Lr
        For j = 0 To UBound(cri)
            If InStr(LCase(.Cells(i, "H")), cri(j)) > 0 Then
                k = k + 1
                arr(k, 1) = .Cells(i, "H").Value
                .Cells(i, "H").ClearContents
            End If
        Next
    Next
    Lrb = Lr
    .Range("H2:H" & Lr).SpecialCells(xlCellTypeBlanks).EntireRow.copy .Range("A" & Lr + 1)
    .Range("2:" & Lrb).Delete
    .Range("H2").Resize(k, 1).Value = arr
End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
airforceone said:
tested it mate with your dummy data and it works well copied the "target" keyword
I manually counted the would be result (26 records) and it successfully copied and pasted it on sheet2...
Click to expand...
It will not work for:
"Windows 10 TTP77"
 
Upvote 0
How about:

VBA Code: 
Sub FindWindowVersions()
'
    Application.ScreenUpdating = False                                                  ' Turn ScreenUpdating off
'
    Dim StartTime               As Single
    StartTime = Timer                                                                   ' Start the stop watch
'
    Dim DestinationSheetExists  As Boolean
    Dim ColumnCount             As Long
    Dim KeyWordsArrayRow        As Long, SourceArrayRow As Long
    Dim SearchForWindowsColumn  As Long
    Dim SourceLastColumnNumber  As Long
    Dim SourceLastRow           As Long, SourceStartRow As Long
    Dim CodeCompletionTime      As Single
    Dim DestinationSheet        As String
    Dim SourceLastColumn        As String
    Dim KeyWordsArray()         As String
    Dim OutputArray             As Variant, SourceArray As Variant
    Dim SourceArrayValue        As Variant
    Dim wsDestination           As Worksheet, wsSource  As Worksheet
'
    DestinationSheet = "Sheet2"                                                 ' <--- Set this to the name of the sheet to store results to
    Set wsSource = ThisWorkbook.Sheets("Sheet1")                                ' <--- Set this to the sheet name of the Source sheet
    SourceStartRow = 2                                                          ' <--- Set this to the start row of data on the source sheet
    SearchForWindowsColumn = 8                                                  ' <--- Set this to the column # to search for versions of windows
'
    On Error Resume Next                                                        ' Bypass error generated in next line if sheet does not exist
    Set wsDestination = ThisWorkbook.Sheets(DestinationSheet)                   ' Assign DestinationSheet to wsDestination
    On Error GoTo 0                                                             ' Turn Excel error handling back on
'
    If Not wsDestination Is Nothing Then DestinationSheetExists = True          ' Check to see if the DestinationSheet exists
'
' Create DestinationSheet if it doesn't exist
    If DestinationSheetExists = False Then                                      ' If DestinationSheet does not exist then ...
        ThisWorkbook.Sheets.Add(after:=wsSource).Name = DestinationSheet        '   Create the DestinationSheet after the Source sheet
        Set wsDestination = ThisWorkbook.Sheets(DestinationSheet)               '   Assign the DestinationSheet to wsDestination
    End If
'
    wsDestination.UsedRange.Delete                                              ' Delete any data on the DestinationSheet

    SourceLastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row              ' Get last row# used in column A of the source sheet
    SourceLastColumn = Split(Cells(1, (wsSource.Cells.Find("*", , _
            xlFormulas, , xlByColumns, xlPrevious).Column)).Address, "$")(1)    ' Get last Column Letter used in the source sheet
'
    SourceLastColumnNumber = wsSource.Cells.Find("*", , xlFormulas, , _
            xlByColumns, xlPrevious).Column                                     ' Get last Column# used in the source sheet
'
    SourceArray = wsSource.Range("A" & SourceStartRow & ":" & _
            SourceLastColumn & SourceLastRow)                                   ' Load 2D 1 based SourceArray RC with all data from the source sheet
'
    ReDim OutputArray(1 To UBound(SourceArray, 1), 1 To UBound(SourceArray, 2)) ' Set the amount of rows & columns for OutputArray
'
'-------------------------------------------------------------------
'
    KeyWordsArray = Split("Windows 7,Win 7,XP", ",")                            ' Establish 1D zero based array of keywords to search for
    DestinationRow = 0                                                          ' Initialize DestinationRow
'
    For SourceArrayRow = 1 To UBound(SourceArray, 1)                            ' Loop through source rows
        SourceArrayValue = SourceArray(SourceArrayRow, SearchForWindowsColumn)  '   Get SourceArrayValue
'
        For KeyWordsArrayRow = LBound(KeyWordsArray) To UBound(KeyWordsArray)   '   Loop through KeyWordsArray
            If Len(KeyWordsArray(KeyWordsArrayRow)) > 0 Then                    '       If a keyword to search for exists then ...
                If InStr(1, SourceArrayValue, KeyWordsArray(KeyWordsArrayRow), _
                        vbTextCompare) > 0 Then                                 '           If keyword found then ...
                    DestinationRow = DestinationRow + 1                         '               Increment DestinationRow
'
                    For ColumnCount = 1 To UBound(SourceArray, 2)               '               Loop through SourceArray columns
                        OutputArray(DestinationRow, ColumnCount) = _
                                SourceArray(SourceArrayRow, ColumnCount)        '                   Save SourceArray row values to OutputArray
                    Next                                                        '               Loop back
'
                    Exit For                                                    '               Exit this For loop
                End If
            End If
        Next                                                                    '   Loop back
    Next                                                                        ' Loop back
'
' Write all header values into the DestinationSheet
    wsDestination.Range("A1:N1").Value = Array("ID", "Must_Pay", "Funded", _
            "Agency", "Directorate_ID", "Division_ID", "Acq_Package", "OS", _
            "Amount_Paid", "Amount_Owed", "Date_Updated", "Start_Date", _
            "End_Date", "Updated_By")                                           ' Write header row to DestinationSheet
'
    wsDestination.Range("A1:N1").Font.Bold = True                               ' Bold the header row
'
    wsDestination.Range("A2").Resize(UBound(OutputArray, 1), _
            UBound(OutputArray, 2)) = OutputArray                               ' Display results to Destination sheet
'
    wsDestination.UsedRange.EntireColumn.AutoFit                                ' Autofit all of the columns on the Destination sheet
'
    Application.ScreenUpdating = True                                           ' Turn ScreenUpdating back on
'
    CodeCompletionTime = Timer - StartTime                                      ' Stop the stop watch
    CodeCompletionTime = Format(CodeCompletionTime, ".#####")                   ' Prevent scientific notation results
    Debug.Print "Time to complete = " & CodeCompletionTime & " seconds."        ' Display the time elapsed to the user (Ctrl-G)
End Sub
 
Upvote 0
And here are the time results:

Post #5 code: 72.81201 avg seconds for 44000 rows

Post #8 code: 2.268555 avg seconds for 44000 rows
 
Upvote 0
Another option, just as a coding exercise on my part :)

VBA Code: 
Option Explicit
Option Compare Text
Sub WinXp()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim i As Long, j As Long, k As Long, ws1 As Worksheet, ws2 As Worksheet
    Dim lr As Long, arrIn(), arrOut(), t As Double: t = Timer
    Set ws1 = Worksheets("Sheet1"): Set ws2 = Worksheets("Sheet2")
    lr = ws1.Cells(Rows.Count, 8).End(xlUp).Row
    
    arrIn = ws1.Range("A2:N" & lr)
    ReDim arrOut(1 To lr - 1, 1 To 14)
    
    i = 1: j = 1
    For i = 1 To UBound(arrIn)
        If arrIn(i, 8) Like "*win*" Or arrIn(i, 8) Like "*xp*" Then
            For k = 1 To UBound(arrIn, 2)
                arrOut(j, k) = arrIn(i, k)
                Next k
                j = j + 1
        End If
    Next i
    
    ws2.Cells(2, 1).Resize(i, 14).Value = arrOut
    ws1.Rows(1).Copy ws2.Cells(1, 1)
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox Timer - t & " secs."
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
VBA Code - Search keywords and paste different results to different sheets
Replies
0
Views
391
JoeDelcambre
J
J
  • Question Question
Find keywords and post on different sheets
Replies
5
Views
548
JoeDelcambre
J
J
  • Question Question
Macro - Find words/terms in cells and paste to new sheet
Replies
3
Views
601
JoeDelcambre
J
O
  • Solved
VBA - Filter columns, cut/paste rows new sheet, pivot table
2
Replies
12
Views
315
Skyybot
Skyybot
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
833
Agnarr
Agnarr

Forum statistics

Threads
1,224,825
Messages
6,181,191
Members
453,021
Latest member
pingpong7117

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