Copy rows based on keyword list to second sheet

[warlock666999]

Hello all, I have an excel sheet with a list of software names on column A and column B has the version number and column C has department name. I want to copy the rows that contain keywords that I have on a third sheet such as acrobat, word, AnyConnect etc on sheet 1 Column A to the second sheet. I would rather have a macro since I have many sheets from different machines.

 

[igold]

How about something like this. The software list you want to search for should start in Cell A1 on Sheet3.

Sub GetSoftware()


    Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
    Dim ws3 As Worksheet: Set ws3 = Worksheets("Sheet3")
    Dim arr
    Dim rng As Range


    'Get software to use in filter
    arr = ws3.Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value


    arr = Application.Transpose(arr)


    'Flilter Sheet1 with data from Sheet3
    ws1.Range("A1").AutoFilter
    ws1.Range("$A$1:$C" & ws1.Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
    
    Set rng = ws1.AutoFilter.Range
    
    rng.Copy ws2.Range("A1")
    ws1.Range("A1").AutoFilter
    ws2.Activate
    
End Sub

 

[warlock666999]

Thank you igold, I will try it out and let you know how everything worked out, thanks again

 

[igold]

You are welcome, I was happy to help.

If it does not work for you, let us know and I am sure a solution can be found.

 

[warlock666999]

I tried it and it only copied one program that's not in the keyword list. I uploaded the excel file to my cloud without macros so you can see it and get a better idea.

Sheet 1 contains the list of software installed
Sheet 2 is where the row will get copied from sheet 1 if it matches the keyword list in sheet 3. So it should copy every row that matches the keyword list in sheet 3.
Sheet 3 has the keyword list

I really appreciate your help and thank you so much

https://tekninja.net/cloud/index.php/s/HXFbYs5GTpcXepG

 

[igold]

Hello all, I have an excel sheet with a list of software names on column A and column B has the version number and column C has department name. I want to copy the rows that contain keywords that I have on a third sheet such as acrobat, word, AnyConnect etc on sheet 1 Column A to the second sheet. I would rather have a macro since I have many sheets from different machines.

I downloaded your workbook, and it is not as described in your post. You have the software name, version number, department name all in column A separated by commas. I can break that information out and split it into 3 columns. The issue is you want to search by single words that are part of the bigger software.

For instance one of your keywords is "Tap" which is part of the software program listed on sheet one as "TAP-Windows 9.23,9.23," which I am guessing you have omitted the department. The real problem is trying to get "Tap" out of "TAP-Windows 9.23".

Perhaps someone with better skills than me can work it for you. I will submit what I have to perhaps save someone some time in retyping. Other than that I am sorry I could not be more help.

Sub GetSoftware()


    Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
    Dim ws3 As Worksheet: Set ws3 = Worksheets("Sheet3")
    Dim desc As String
    Dim kwords
    Dim rng As Range
    Dim arr, slines, lines
    Dim i As Long, x As Long, y As Long


    'Get software to use in filter
    arr = ws1.Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    For i = LBound(arr) To UBound(arr)
        desc = desc & ";" & arr(i, 1)
    Next
    lines = Split(desc, ";")
    ReDim kwords(1 To UBound(lines))
    For x = 1 To UBound(lines)
        slines = Split(lines(x), ",")
        kwords(x) = "*" & slines(0) & "*"
    Next
    
    arr = Application.Transpose(kwords)


    'Flilter Sheet1 with data from Sheet3
    ws1.Range("A1").AutoFilter
    ws1.Range("$A$1:A" & ws1.Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
    Set rng = ws1.AutoFilter.Range
    
    rng.Copy ws2.Range("A1")
    ws1.Range("A1").AutoFilter
    ws2.Activate
    
End Sub

 

[Fluff]

How about

Sub warlock()
    Dim Ary As Variant, Nary As Variant, Crit As Variant
    Dim i As Long, j As Long, k As Long
    
    With Sheets("Sheet3")
        Crit = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value2
    End With
    With Sheets("Sheet1")
        Ary = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value2
    End With
    ReDim Nary(1 To UBound(Ary), 1 To 1)
    For i = 1 To UBound(Ary)
        For j = 1 To UBound(Crit)
            If InStr(1, Ary(i, 1), Crit(j, 1), vbTextCompare) > 0 Then
                k = k + 1
                Nary(k, 1) = Ary(i, 1)
                Exit For
            End If
        Next j
    Next i
    Sheets("Sheet2").Range("A1").Resize(k).Value = Nary
End Sub

 

[igold]

@Fluff

Nice!

igold

 

[warlock666999]

Thank you for your help igold, I apologize for the confusion I caused. The actual sheet I did not have with me that has the departments I just made that one up quick. But Fluff's solution is exactly what I wanted. Thank you guys so much for the help, you guys Rock!

 

[igold]

I am sorry I could not be more help. At least you got a bump out of it and @Fluff got it done for you.

Thanks for the feedback.