필터링 된 범위의 서식 만 붙여 넣기

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 코드는 다음과 같습니다 :

I 값과 형식,뿐만 아니라 형식을 복사 관리해야

주

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 

: 내가 만들 줄을 포함하지 않은 필자는 필터를 적용한 후에 매크로를 실행하고 있다고 가정했습니다. 경우에 당신은 너무 그것을 자동화 할, 매크로의 상단에 같은 것을 사용해야합니다 :

Filtered formatting

: 여기

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

하면 매크로를 실행 한 후 데이터의 스크린 샷입니다 수정과

Answer 2

@Mahesh의 솔루션은 필터링 된 모든 행을 고려합니다 : (https://stackoverflow.com/tour), 읽기

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