VBA - Help with Copy/Paste/Filter

ExcelMercy

Board Regular
Joined
Aug 11, 2014
Messages
151
Hey All,


Having a bit of an issue, can't seem to get the filter to correctly.. uh, filter! Any help would be greatly appreciated!




Here is the code:
Code:
Sub Market_Confirm_Test()
    'Switch to Market Totals Tab
        Sheets("Market_Totals").Select
 
Dim ws11     As Worksheet
Dim ws12     As Worksheet
Dim x       As Long
Dim y       As Long
Dim i       As Long
Dim arr()   As Variant
Const SystemCode As String = "AP_123_Lo_4 AP_123_Lo_6 JF_123_Lo_1_SYS JF_123_Lo_2 HG_123_Lo_2_SYS"
    Application.ScreenUpdating = False
    Set ws11 = ActiveSheet
    Set ws12 = Worksheets.Add
    With ws12
        .Name = "Market_Confirm"
        .Move after:=Sheets(Sheets.Count)
        x = 1
        For Each Var In Array("System Code", "First Name", "Last Name", "Address 1", "City", "State", "Market ID")
            .Cells(1, x).Value = CStr(Var)
            x = x + 1
        Next Var
    End With
    With ws11
        If .AutoFilterMode Then .AutoFilterMode = False
        x = .Range("D" & .Rows.Count).End(xlUp).Row
        y = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        arr = .Range("D2:D" & x).Value
 
        .Cells(1, y).Value = "Filter row"
        For i = LBound(arr, 1) To UBound(arr, 1)
            If InStr(SystemCode, CStr(arr(i, 1))) Then
                arr(i, 1) = True
            Else
                arr(i, 1) = False
            End If
        Next i
        .Cells(2, y).Resize(UBound(arr, 1)).Value = arr
        .Cells(1, y).Resize(x).AutoFilter Field:=1, Criteria1:=False
        .Range("D2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
        ws12.Range("A2").PasteSpecial xlPasteAll
        .Range("F2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
        ws12.Range("B2").PasteSpecial xlPasteAll
        .Range("H2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
        ws12.Range("C2").PasteSpecial xlPasteAll
        .Range("I2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
        ws12.Range("D2").PasteSpecial xlPasteAll
        .Range("K2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
        ws12.Range("E2").PasteSpecial xlPasteAll
        .Range("L2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
        ws12.Range("F2").PasteSpecial xlPasteAll
        .Range("B2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
        ws12.Range("G2").PasteSpecial xlPasteAll
        Application.CutCopyMode = False
        .Cells(1, y).Resize(x).Clear
    End With
    Application.ScreenUpdating = True
    Set ws11 = Nothing
    Set ws12 = Nothing
    Erase arr
End Sub

Starting Sheet (Market_Totals)
Type
Market ID
Order by
System Code
Name id
First Name
Middle Initial
Last Name
Address 1
Address 2
City
State
Postal code
1
213546
*
AP_123_Lo_4
75473d
Billy
C
Smith
111 N Street
Philadelphia
PA
12345
1
432452
*
AP_123_Lo_5
756859d
Jacob
Johnson
123 S Street
New Orleans
LA
84001
1
3425267
*
AP_123_Lo_6
7646d
Sue
Doe
123 Main St
Atlanta
GA
65431
1
8798567
*
AP_123_Lo_7
435322fg
Becky
A
Smith
123 NorthWest Main Rd
Nashville
TN
45678
2
679732542
*
AP_123_Lo_8
4325253fg
Stacy
Marshall
9483 Walkway Dr
Houston
TX
54634
2
3242368
*
JF_123_Lo_1_SYS
23215fg
Larence
S
Donald
2143 Systems Avn
New Orleans
LA
84001
1
6775674
*
JF_123_Lo_2
64345d
Kimberly
Jones
123 Timber Rd
Nashville
TN
54001
1
53424567
*
JF_123_Lo_2
6788900d
Mike
G
Gareld
136 South rd
Philadelphia
PA
45201
1
8798567
*
HG_123_Lo_1_SYS
6422fg
Becky
A
Smith
788 Landing Rd
Nashville
TN
45678
2
679732542
*
HG_123_Lo_1_SYS
6233fg
Stacy
Marshall
3 Moore Dr
Philadelphia
PA
85201
2
3242368
*
HG_123_Lo_1_SYS
5234fg
Larence
S
Donald
212 Lake Drive
Philadelphia
PA
95201
1
6775674
*
HG_123_Lo_2_SYS
3125d
Kimberly
Jones
1677 Trees Rd
New Orleans
LA
84001
1
53424567
*
HG_123_Lo_2_SYS
432656d
Mike
G
Gareld
13455 Northsouth Rd
Philadelphia
PA
65201

<tbody>
</tbody>





Output I want:
System Code
First Name
Last Name
Address 1
City
State
Market ID
AP_123_Lo_4
Billy
Smith
111 N Street
Philadelphia
PA
213546
AP_123_Lo_6
Jacob
Johnson
123 S Street
New Orleans
LA
432452
JF_123_Lo_1_SYS
Larence
Donald
2143 Systems Avn
New Orleans
LA
3242368
JF_123_Lo_2
Kimberly
Jones
123 Timber Rd
Nashville
TN
6775674
HG_123_Lo_2_SYS
Kimberly
Jones
1677 Trees Rd
New Orleans
LA
6775674
HG_123_Lo_2_SYS
Mike
Gareld
13455 Northsouth Rd
Philadelphia
PA
53424567

<tbody>
</tbody>




Output I'm getting:

System Code
First Name
Last Name
Address 1
City
State
Market ID
AP_123_Lo_5
Jacob
Johnson
123 S Street
New Orleans
LA
432452
AP_123_Lo_7
Becky
Smith
123 NorthWest Main Rd
Nashville
TN
8798567
AP_123_Lo_8
Stacy
Marshall
9483 Walkway Dr
Houston
TX
6.8E+08
HG_123_Lo_1_SYS
Becky
Smith
788 Landing Rd
Nashville
TN
8798567
HG_123_Lo_1_SYS
Stacy
Marshall
3 Moore Dr
Philadelphia
PA
6.8E+08
HG_123_Lo_1_SYS
Larence
Donald
212 Lake Drive
Philadelphia
PA
3242368

<tbody>
</tbody>
 
That's strange. It is still working for me.

You will have to make sure that the sheet called Market_Confirm has been deleted, though. But that is as it was before.

Here is a version that makes sure the Market_Confirm worksheet is removed prior to starting. I think I got it right this time.
Code:
Sub Market_Confirm_Test()
    
    Dim ws11       As Worksheet
    Dim ws12       As Worksheet
    Dim x          As Long
    Dim y          As Long
    Dim SystemCode As Variant
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("Market_Confirm").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set ws11 = ThisWorkbook.Worksheets("Market_Totals")
    Set ws12 = Worksheets.Add
    
    SystemCode = Array("AP_123_Lo_4", "AP_123_Lo_6", "JF_123_Lo_1_SYS", "JF_123_Lo_2", "HG_123_Lo_2_SYS")

    With ws12
        .Name = "Market_Confirm"
        .Move after:=Sheets(Sheets.Count)
        .Range("A1").Resize(1, 7).Value = Array("System Code", "First Name", "Last Name", "Address 1", "City", "State", "Market ID")
    End With
    
    With ws11
        If .AutoFilterMode Then .AutoFilterMode = False
        x = .Range("D" & .Rows.Count).End(xlUp).Row
        y = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1

         .Cells(1, "D").Resize(x).AutoFilter Field:=1, Criteria1:=SystemCode, Operator:=xlFilterValues
        If .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
            .Range("D2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
            ws12.Range("A2").PasteSpecial xlPasteAll
            .Range("F2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
            ws12.Range("B2").PasteSpecial xlPasteAll
            .Range("H2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
            ws12.Range("C2").PasteSpecial xlPasteAll
            .Range("I2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
            ws12.Range("D2").PasteSpecial xlPasteAll
            .Range("K2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
            ws12.Range("E2").PasteSpecial xlPasteAll
            .Range("L2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
            ws12.Range("F2").PasteSpecial xlPasteAll
            .Range("B2").Resize(x - 1).SpecialCells(xlCellTypeVisible).Copy
            ws12.Range("G2").PasteSpecial xlPasteAll
        End If
    End With
    
    Application.ScreenUpdating = True
    Set ws11 = Nothing
    Set ws12 = Nothing

End Sub
 
Upvote 0

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Would it possible to add like an IF around the entire thing.


Like, don't even make Market_Confirm if ("AP_123_Lo_4", "AP_123_Lo_6", "JF_123_Lo_1_SYS", "JF_123_Lo_2", "HG_123_Lo_2_SYS") isn't found on Market_Totals?
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,186
Members
448,554
Latest member
Gleisner2

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