VBA If statement with filtered values

Attached is a spreadsheet which has filtered values in sheet Table1.  In trying to write some code that would put the word "Inbound" in one Cell and the three Outbound words in other cells, the code keeps throwing an error.

How can the code be written to place any visible text value, from a filtered table, into a cell and then place a second text value text value into a separate cell.
Cook09
Filter_Copy.xlsm
Cook09Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

ShumsDistinguished Expert - 2017Commented:
Hi Cook09,

Please use below code:
Sub CopyFilteredRow()
Dim SrcWs As Worksheet, DestSh As Worksheet
Dim SrcLR As Long
Dim CritRng As Range
Dim InBnd As String, OutBnd As String
Dim c As Range, ar As Range
Dim DestRow As Long
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = True
    .StatusBar = "!!! Please Be Patient...Updating Records !!!"
    .EnableEvents = False
    .Calculation = xlManual
End With

Set SrcWs = Worksheets("Table1")
Set DestSh = Worksheets("Main")
SrcLR = SrcWs.Range("A" & Rows.Count).End(xlUp).Row
DestSh.Range("A4:G100").ClearContents
DestSh.Range("A1").ClearContents
SrcWs.Range("B2", SrcWs.Cells(SrcWs.Rows.Count, "B").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Copy
DestSh.Range("A1").PasteSpecial xlPasteValues
InBnd = "INBOUND"
OutBnd = "OUTBOUND"
DestRow = 4
Set CritRng = SrcWs.Range("N2:N" & SrcLR).SpecialCells(xlCellTypeVisible)
For Each ar In CritRng.Areas
    For Each c In ar
        If c.Value = InBnd Then
            SrcWs.Range("A" & c.Row).Copy
            DestSh.Range("A" & DestRow).PasteSpecial xlPasteValues
            SrcWs.Range("C" & c.Row).Copy
            DestSh.Range("B" & DestRow).PasteSpecial xlPasteValues
            SrcWs.Range("F" & c.Row).Copy
            DestSh.Range("C" & DestRow).PasteSpecial xlPasteValues
            DestRow = DestRow + 1
        ElseIf c.Value = OutBnd Then
            SrcWs.Range("A" & c.Row).Copy
            DestSh.Range("E" & DestRow).PasteSpecial xlPasteValues
            SrcWs.Range("C" & c.Row).Copy
            DestSh.Range("F" & DestRow).PasteSpecial xlPasteValues
            SrcWs.Range("F" & c.Row).Copy
            DestSh.Range("G" & DestRow).PasteSpecial xlPasteValues
            DestRow = DestRow + 1
        End If
    Next c
Next ar

Application.CutCopyMode = False
DestSh.Activate
DestSh.Columns.AutoFit
DestSh.Range("A4").Select
ActiveWindow.FreezePanes = True
With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .StatusBar = False
    .EnableEvents = True
    .Calculation = xlAutomatic
End With
End Sub

Open in new window

Please find attached...
Filter_Copy_v1.xlsm
0
ShumsDistinguished Expert - 2017Commented:
Hi Cook,

I have made some changes as you wanted Outbound details below Inbound. Assuming your Inbound filter will not have more than 5 entries, then below code can work:
Sub CopyFilteredRow()
Dim SrcWs As Worksheet, DestSh As Worksheet
Dim SrcLR As Long
Dim CritRng As Range
Dim InBnd As String, OutBnd As String
Dim c As Range, ar As Range
Dim IndRow As Long, OutRow As Long
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = True
    .StatusBar = "!!! Please Be Patient...Updating Records !!!"
    .EnableEvents = False
    .Calculation = xlManual
End With

Set SrcWs = Worksheets("Table1")
Set DestSh = Worksheets("Main")
SrcLR = SrcWs.Range("A" & Rows.Count).End(xlUp).Row
DestSh.Range("A1").ClearContents
DestSh.Range("A4:C9").ClearContents
DestSh.Range("A12:C17").ClearContents
SrcWs.Range("B2", SrcWs.Cells(SrcWs.Rows.Count, "B").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Copy
DestSh.Range("A1").PasteSpecial xlPasteValues
InBnd = "INBOUND"
OutBnd = "OUTBOUND"
IndRow = 4
OutRow = 12
Set CritRng = SrcWs.Range("N2:N" & SrcLR).SpecialCells(xlCellTypeVisible)
For Each ar In CritRng.Areas
    For Each c In ar
        If c.Value = InBnd Then
            SrcWs.Range("A" & c.Row).Copy
            DestSh.Range("A" & IndRow).PasteSpecial xlPasteValues
            SrcWs.Range("C" & c.Row).Copy
            DestSh.Range("B" & IndRow).PasteSpecial xlPasteValues
            SrcWs.Range("F" & c.Row).Copy
            DestSh.Range("C" & IndRow).PasteSpecial xlPasteValues
            IndRow = IndRow + 1
        ElseIf c.Value = OutBnd Then
            SrcWs.Range("A" & c.Row).Copy
            DestSh.Range("A" & OutRow).PasteSpecial xlPasteValues
            SrcWs.Range("C" & c.Row).Copy
            DestSh.Range("B" & OutRow).PasteSpecial xlPasteValues
            SrcWs.Range("F" & c.Row).Copy
            DestSh.Range("C" & OutRow).PasteSpecial xlPasteValues
            OutRow = OutRow + 1
        End If
    Next c
Next ar

Application.CutCopyMode = False
DestSh.Activate
DestSh.Columns.AutoFit
DestSh.Range("A4").Select
ActiveWindow.FreezePanes = True
With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .StatusBar = False
    .EnableEvents = True
    .Calculation = xlAutomatic
End With
End Sub

Open in new window

Please find attached....
Filter_Copy_v3.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Cook09Author Commented:
Excellent!!!!
Both the Pivot and the VBA are exactly what I needed.  Not sure why there was an issue with the xlCellTypeVisible, but what you put together does work.  Thanks for the Pivot...need to begin using this more.  May have saved quite a bit of time.

Wish I could allot more points for two solutions...but....
0
ShumsDistinguished Expert - 2017Commented:
hehehe. Thanks Cook for such comments.

You're always welcome! Glad I was able to provide solution as you expected.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.