Paste only formats in filtered range

Question

I have some data in a spreadsheet that can be filtered through column A. Only the first row of each type of rows has the desired format.

Data

Once filtered, I need to copy the format from the first row to paste it to the rest of the range (visible cells only).

The final result after running the macro should be:

Data after macro

I'm stuck and I can't find anything on the net which fits. Can anybody help?

I have managed to copy values and formats, but not only formats:

Sub Repair()
Dim i As Integer
Dim FirstRow As Long, LastRow As Long
Dim Rang1 As Range, Rang2 As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With ActiveSheet
    .Cells.EntireColumn.Hidden = False  'Show all
    .AutoFilterMode = False 'Filter off
    .Columns("A:A").Select
    Selection.AutoFilter 'Filter column A
End With

'Row 1 is header

'Filter type "P":
ActiveSheet.Range("A:A").AutoFilter Field:=1, Criteria1:="P", Operator:=xlFilterValues

'Create Range from filtered data
Set Rang1 = Range("A2", 
Range("A2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible)
FirstRow = Rang1.Row 'First row of filtered data
LastRow = LastFilteredRow 'Last row of filtered data

'Change values and formats:
Range("B" & FirstRow & ":D" & LastRow & ",H" & FirstRow & ":H" & LastRow & ",J" & FirstRow & ":K" & LastRow).Select
Selection.FillDown

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Function LastFilteredRow() As Long
Dim Rng As Range
Dim x As Variant
Dim LastAddress As String
On Error GoTo NoFilterOnSheet
With ActiveSheet.AutoFilter.Range
    Set Rng = .Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible)
    x = Split(Replace(Rng.Address, ",", ":"), ":")
    LastAddress = x(UBound(x))
    LastFilteredRow = Range(LastAddress).Row
End With
NoFilterOnSheet:
End Function

Answer 1

Here's the VBA code:

Sub Paste_Formats_Only()
    Dim visible_rows() As String, format_source As String
    Dim c as Range, i as Long
    Const TOP_ROW As Long = 2

    Application.ScreenUpdating = False

    'visible_rows = Split(Range("A1").SpecialCells(xlCellTypeVisible).Address, ",")
    i = 0
    For Each c In Range("A1").SpecialCells(xlCellTypeVisible).Areas
        ReDim Preserve visible_rows(i)
        visible_rows(UBound(a)) = c.Address
        i = i + 1
    Next c
    format_source = Application.Intersect(Rows(TOP_ROW), ActiveSheet.UsedRange).Address

    Range(format_source).Copy
    For i = (LBound(visible_rows) + 1) To (UBound(visible_rows) - 1)
        Application.Intersect(Range(visible_rows(i)), ActiveSheet.UsedRange).PasteSpecial xlPasteFormats
    Next i
    Application.CutCopyMode = False

    Range("A1").Select
End Sub

Note: I haven't included the line to create the filter as I've assumed you'd be running the macro after applying it. In case you want to automate that too, you'll have to use something like this at the top of the macro:

Range("A1").AutoFilter Field:=1, Criteria1:="P"

Here's a screenshot of your data after running the macro:

Filtered formatting