Filldown Visible Cells in a Column

user_17236057 0
Viewed 116

I need some help. I have two columns: A and B. Column A and Column B have the following headers "Status" and "State". A filter has been applied to select "down" from a choice of "up" and "down" in Column A. When Column A is filtered some blank cells are revealed in Column B after some cells in Column B is cleared. The amount of data in the sheet varies and the position of these blanks also vary. I will like to fill down these blank cells in Column B using the values in visible cells only (not from the values in the hidden cells). Can someone help me edit this code?

In the pic above SO will fill down from 50476 to 50492 without erasing the values in the hidden cells.

Sub Filldownvisiblecells ()

Dim ws as worksheet
Dim dl as long
Dim rg as range

ws = Workbooks("Book1.xlsm"). Worksheets("Sheet1")
dl = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

'Filter Column A by Down
ws.Range("A1").AutoFilter Field:=1, Criteria1:="Down"

'Clearing States in Column B (This action generates blanks that I will like to filldown from visible cells NOT hidden cells)
ws.Range("B2:B" & dl).SpecialCells(xlCellTypeVisible).Select
For Each rg In Selection.Cells
If rg.Text = "R1" Or rg.Text = "R2" Or rg.Text = "UT" Then
rg.ClearContents
End If
Next rg

'Select Filldown Range in Column B
ws.Range("B2:B" & dl). SpecialCells(xlCellTypeVisible).Select

'Filldown Blanks in Column X
For Each rg In Selection.Cells
If rg.Value = "" Then
rg.FillDown
End If
Next rg

End Sub
autofilter vba excel
1 Answers

Fill Down With Visible Cells' Values (AutoFilter)

Option Explicit

Sub FillDownVisible()
    
    Const wsName As String = "Sheet1"
    
    Const fRow As Long = 1 ' First Row
    Const fCol As String = "A" ' Filter Column
    Const fCriteria As String = "Down" ' Filter Criteria
    
    Const dCol As String = "B" ' Destination Column
    
    Dim ws As Worksheet
    ' The Workbook Containing This Code ('ThisWorkbook')
    Set ws = ThisWorkbook.Worksheets(wsName)
    ' An Open Workbook
    'Set ws = Workbooks("Book1.xlsm").Wordksheets(wsname)
    ' Possibly Closed Workbook (Needs the Full File Path)
    'Set ws = Workbooks.Open("C:\Test\Book1.xlsm").Worksheets(wsName)
    
    ' Clear possible previous ('active') filter.
    If ws.AutoFilterMode Then
        ws.AutoFilterMode = False
    End If
    ' Create a reference to the Filter Range ('frg').
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, fCol).End(xlUp).Row
    Dim frg As Range: Set frg = ws.Cells(fRow, fCol).Resize(lRow - fRow + 1)
    ' Create a reference to the Destination Data Range (no headers).
    Dim ddrg As Range: Set ddrg = frg.EntireRow.Columns(dCol) _
        .Resize(frg.Rows.Count - 1).Offset(1)
    ' Filter Filter Range.
    frg.AutoFilter Field:=1, Criteria1:=fCriteria
    
    ' Create a reference to the Destination Range ('drg').
    Dim drg As Range: Set drg = ddrg.SpecialCells(xlCellTypeVisible)
    
    Dim dCell As Range ' Current Destination Cell
    Dim pValue As Variant ' Previous Value
    Dim cValue As Variant ' Current Value
    
    ' Loop through the cells of the Destination Range.
    For Each dCell In drg.Cells
        cValue = dCell.Value
        Select Case UCase(CStr(cValue))
        Case "R1", "R2", "UT", ""
            dCell.Value = pValue
        Case Else
            pValue = cValue
        End Select
    Next dCell

    ws.AutoFilterMode = False

End Sub
user_98140690
Related