VBA If statement with filtered values

Cook09
Cook09 used Ask the Experts™
on
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
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
ShumsManaging Director/Excel VBA Developer
Distinguished Expert 2018

Commented:
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
Managing Director/Excel VBA Developer
Distinguished Expert 2018
Commented:
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

Author

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....
ShumsManaging Director/Excel VBA Developer
Distinguished Expert 2018

Commented:
hehehe. Thanks Cook for such comments.

You're always welcome! Glad I was able to provide solution as you expected.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial