VBA macro to copy rows with multiple values and paste to a new sheet

[JoeDelcambre]

Hi,

I'm not super proficient with VBA, and I'm stuck. I'm trying to write a VBA macro to search a worksheet for several different values/words, copy those rows and paste rows to a new sheet. I'm working with some large worksheets.

 

[JoeDelcambre]

Hi,

I'm not super proficient with VBA, and I'm stuck. I'm trying to write a VBA macro to search a worksheet for several different values/words, copy those rows and paste rows to a new sheet. I'm working with some large worksheets.

And any tips on a way to add filters to the pasted results on the new sheet would help greatly.

 

[mohadin]

Hi
If you can show a sample, would be easier

 

[JoeDelcambre]

Hi
If you can show a sample, would be easier

Yes, that would be easier. Sorry about that. I am attaching a worksheet I created randomly.

For the macro, let's say I need to copy the rows that contain any of the following:
Windows 7
windows 7
Win 7
win 7
XP
Win XP
win xp
windows XP

Then, paste the rows to a new spreadsheet including all columns.

Thanks for the help!

 

[kevin9999]

Maybe this..

Option Explicit
Sub JoeDelcambre()
    Dim ws1 As Worksheet, ws2 As Worksheet, ar
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    ar = Array("Windows 7", "windows 7", "Win 7", "win 7", "XP", "Win XP", "win xp", "windows XP")
    
    With ws1.Cells(1, 1).CurrentRegion
        .AutoFilter 8, Array(ar), 7
        .Copy ws2.Cells(1, 1)
        .AutoFilter
    End With
    ws2.Cells(1, 1).AutoFilter
End Sub

 

[mohadin]

Try

Sub test()
    Dim a
    Dim x, i, c, ii
    c = 1
    x = Array("Windows 7", "Windows 7", "win 7", "win 7", "XP", "win XP", "win XP", "Windows XP")
    a = Sheets("sheet1").Cells(2, 1).CurrentRegion
    ReDim B(1 To UBound(a), 1 To UBound(a, 2) - 1)
    For i = 1 To UBound(a)
        ii = IsNumeric(Application.Match(a(i, 8), x))
        If IsNumeric(Application.Match(a(i, 8), x)) = True Then
            For ii = 1 To UBound(B, 2)
                B(c, ii) = a(i, ii)
            Next
            c = c + 1
        End If
    Next
    Sheets("Sheet2").Cells(2, 1).Resize(c - 1, UBound(B, 2)) = B
End Sub

 

[JoeDelcambre]

Maybe this..

Option Explicit
Sub JoeDelcambre()
    Dim ws1 As Worksheet, ws2 As Worksheet, ar
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
   
    ar = Array("Windows 7", "windows 7", "Win 7", "win 7", "XP", "Win XP", "win xp", "windows XP")
   
    With ws1.Cells(1, 1).CurrentRegion
        .AutoFilter 8, Array(ar), 7
        .Copy ws2.Cells(1, 1)
        .AutoFilter
    End With
    ws2.Cells(1, 1).AutoFilter
End Sub

This worked great!!! Thanks a million!!!

 

[JoeDelcambre]

Try

Sub test()
    Dim a
    Dim x, i, c, ii
    c = 1
    x = Array("Windows 7", "Windows 7", "win 7", "win 7", "XP", "win XP", "win XP", "Windows XP")
    a = Sheets("sheet1").Cells(2, 1).CurrentRegion
    ReDim B(1 To UBound(a), 1 To UBound(a, 2) - 1)
    For i = 1 To UBound(a)
        ii = IsNumeric(Application.Match(a(i, 8), x))
        If IsNumeric(Application.Match(a(i, 8), x)) = True Then
            For ii = 1 To UBound(B, 2)
                B(c, ii) = a(i, ii)
            Next
            c = c + 1
        End If
    Next
    Sheets("Sheet2").Cells(2, 1).Resize(c - 1, UBound(B, 2)) = B
End Sub

This code worked great!!! Thank you very much for your help!

 

[kevin9999]

This worked great!!! Thanks a million!!!

Glad we could help, and thanks for the feedback

 

[JoeDelcambre]

Glad we could help, and thanks for the feedback

I think I should have added more detail to the test file I posted. I should have added a second sheet. I thought I would be able to tweak the macro a bit to fit my needs, but I think I need help to finish it off.

Let's say "Sheet1" and "Sheet2" have similar info, and I need to find 2 more values:

Vista
vista
Windows 7
windows 7
WIn 7
win7
XP
Win XP
win xp
windows XP

Then, paste on "Sheet3". Any help is greatly appreciated.