フィルタリングされたデータのみをコピーするコード

Question

このコードは大部分は機能しますが、フィルタリングされたデータだけでなく、データセット内のすべてのデータをコピーします。私はそれを踏んだときにフィルタが正しく動作していますが、すべてをコピーします。私は間違って何をしていますか？

Sub Auto_Filter() 

Dim RNG As Range 
Dim Open_Jobs_Report As Worksheet 
Set Open_Jobs_Report = ThisWorkbook.Sheets("Open Jobs Report") 
Dim Calculations As Worksheet 
Set Calculations = ThisWorkbook.Sheets("Calculations") 
Dim PersonResponsible As Range 
Dim Violations As Range 
Dim CLM1 As Long 
Dim CLM2 As Long 


    With Sheets("Open Jobs Report") 
     Set RNG = .Range("A1", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column)) 
     RNG.AutoFilter Field:=19, Criteria1:="<>" 

     CLM1 = .Range("1:1").Find(What:="Person Responsible").Column 
     Set PersonResponsible = .Range(.Cells(1, CLM1), .Cells(1, CLM1).End(xlDown)) 
     CLM2 = .Range("1:1").Find(What:="Violations").Column 
     Set Violations = .Range(.Cells(1, CLM2), .Cells(1, CLM2).End(xlDown)) 

    End With 


    Calculations.Range("A:A").Value = PersonResponsible.Value 
    Calculations.Range("B:B").Value = Violations.Value 




    With Sheets("Open Jobs Report") 

    ActiveSheet.ListObjects(1).AutoFilter.ShowAllData '<= Fix this 

    End With 

End Sub 

Answer 1

このようにすれば、データをコピーする必要がある他の範囲で範囲を置き換えることができます。

dim r As Range 
dim x(1 to 100,1 to 1) 
i = 1 
    For Each r In PersonResponsible.SpecialCells(xlCellTypeVisible) 
     x(i,1) = r :i = i + 1 
    Next 
    Calculations.Range("A1").resize(i-1).value = x 

編集： たぶん、このような何か、このようなもので

PersonResponsible.SpecialCells(xlCellTypeVisible).Copy _ 
     Destination:=Calculations.Range("A1") 

Answer 2

使用Advanced Filter：私ができる場合、私はむしろ、ループを回避する

Dim rCriteria as Range 
Set rCriteria = [Headears of columns you want] 

RNG.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= rCriteria, _ 
         CopyToRange:=[where you want], Unique:=True