フィルタリングされた範囲内の書式のみを貼り付けます。

Question

スプレッドシートには、A列でフィルタリングできるデータがあります。各行の最初の行だけが目的の形式です。一旦濾過

Data

、Iは範囲（のみ可視細胞）の残りの部分に貼り付けるために、第1行からフォーマットをコピーする必要があります。

マクロを実行した後、最終的な結果は次のようになります。

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