We help IT Professionals succeed at work.

VBA If statement with filtered values

192 Views
Last Modified: 2017-03-27
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

ShumsManaging Director/Excel VBA Developer
CERTIFIED EXPERT
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
CERTIFIED EXPERT
Distinguished Expert 2018
Commented:
This problem has been solved!
(Unlock this solution with a 7-day Free Trial)
UNLOCK SOLUTION

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
CERTIFIED EXPERT
Distinguished Expert 2018

Commented:
hehehe. Thanks Cook for such comments.

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