は、VBAをエクセル - オートフィルタ

Question

後、私は次の操作を実行するマクロを記述しようとしているヘッダを除くすべてのフィルターの行を選択：シート1から

• データI入力の欄を見て、
• A列のセルに何かを書き込むと、その値がSheet2にフィルタリングされます。
• フィルタを実行した後、複数の値があっても、2番目のシートの列見出しを除くすべてを最初のシートにコピーします。 Iは、ヘッダ行が同様にコピーされる選択をコピーし、しかし.Offset使用する場合しかし（1、0）ヘッダと1つの追加の行をカットしdoesnの

  Private Sub Worksheet_Change(ByVal Target As Range) 
      Dim KeyCells As Range 
      Set KeyCells = Range("A:A") 
      If Not Application.Intersect(KeyCells, Range(Target.Address)) _ 
        Is Nothing Then 
       copy_filter Target 
      End If 
  End Sub 
  
  Sub copy_filter(Changed) 
      Set sh = Worksheets("Sheet2") 
      sh.Select 
  
      sh.Range("$A$1:$L$5943") _ 
       .AutoFilter Field:=3, _ 
        Criteria1:="=" & Changed.Value, _ 
        VisibleDropDown:=False 
      Set rang = sh.Range("$A$1:$L$5943") _ 
       .SpecialCells(xlCellTypeVisible) 
  
      rang.Offset(0, 0).Select 
      Selection.Copy 
  
      Worksheets("Sheet1").Select 
      Worksheets("Sheet1").Range(Changed.Address).Offset(0, 1).Select 
      Selection.PasteSpecial Paste:=xlPasteValues 
  
      sh.Range("$A$1:$L$5943").AutoFilter 
      Application.CutCopyMode = False 
  End Sub 
  

  ：

私はこれを書いてみましたフィルタが結果を返さない場合を考慮する必要があります。

ヘッダー以外のすべてのフィルタリングされた行を選択するにはどうすればよいですか？

Answer 1

sh.UsedRangeを使用すると、ダイナミックレンジが得られます。ここでは、sh.Range("$A$1:$L$5943")は縮小せず、データセットと一致するように成長しません。
我々はこのようにヘッダー行をトリミングすることができます返すようにデータが存在しない場合

Set rang = sh.UsedRange.Offset(1, 0) 
    Set rang = rang.Resize(rang.Rows.Count - 1) 

しかしSpecialCells(xlCellTypeVisible)はNo cells were found.エラーがスローされます。私はその値を使用列のセルで何かを書くとき

On Error Resume Next 

Set rang = rang.SpecialCells(xlCellTypeVisible) 

If Err.Number = 0 Then 

End If 

On Error GoTo 0 

 
    Sub copy_filter(Changed) 
     Dim rang As Range 

     Set sh = Worksheets("Sheet2") 

     sh.UsedRange.AutoFilter Field:=3, _ 
           Criteria1:="=" & Changed.Value, _ 
           VisibleDropDown:=False 


     Set rang = sh.UsedRange.Offset(1, 0) 
     Set rang = rang.Resize(rang.Rows.Count - 1) 

     On Error Resume Next 
     Set rang = rang.SpecialCells(xlCellTypeVisible) 
     If Err.Number = 0 Then 
      rang.Copy 
      Worksheets("Sheet1").Range(Changed.Address).Offset(0, 1).PasteSpecial Paste:=xlPasteValues 
     End If 

     On Error GoTo 0 

     sh.Cells.AutoFilter 

     Application.CutCopyMode = False 


    End Sub