仅粘贴过滤范围内的格式

Question

我在电子表格中有一些数据可以通过 A 列进行过滤。只有每种类型的行的第一行具有所需的格式。

Data

过滤后，我需要从第一行复制格式以将其粘贴到范围的其余部分（仅限可见单元格）。

运行宏后的最终结果应该是：

Data after macro

我卡住了，我在网上找不到合适的东西。有人可以帮忙吗？

我已经成功复制了值和格式，但不仅仅是格式：

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

这是 VBA 代码：

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

注意： 我没有包含创建过滤器的行，因为我假设您在应用它后会成为运行宏。如果你也想自动化，你必须在宏的顶部使用这样的东西：

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

这是运行宏后数据的屏幕截图：

Filtered formatting

Answer 2

@Mahesh 的解决方案经过修改以考虑所有过滤的行：

Sub Paste_Formats_Only2()
Dim format_source As String, i As Integer
Dim TOP_ROW As Range, Rang1 As Range

Application.ScreenUpdating = False

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

format_source = Application.Intersect(Rows(TOP_ROW), ActiveSheet.UsedRange).Address

Range(format_source).Copy
For Each rw In Rang1
    Application.Intersect(Rows(rw.Row), Range(formatable_columns(j))).PasteSpecial xlPasteFormats
Next
Application.CutCopyMode = False

Range("A1").Select
End Sub

仅粘贴过滤范围内的格式

Paste only formats in filtered range

excel

vba

copy-paste

autofilter