VBA内の別のシートのフィルタテーブルに基づくサイズ変更テーブル

Question

ワークシート上のあるテーブルのデータ範囲を、別のワークシート内の別のテーブルのデータ範囲にコピーしようとしています。ヘッダーの内容を取りたいとは思っていません。左端の列を削除する方法を知りたいのですが、フィルタリングする必要があります。

テーブルのサイズを変更する方法を理解しようとしています。範囲をコピーしているテーブルのサイズに基づいて値を貼り付けようとしています。

Sub AdjustedTablebyDistrict() 
'Application.ScreenUpdating = False 

Dim i As Integer 

Dim tbl As ListObject 
Dim tbl2 As ListObject 
Dim tbl3 As ListObject 
Dim tbl4 As ListObject 

'Identify tables for paste job 
Set tbl = Worksheets("BaseSheet").ListObjects("Table1") 
Set tbl2 = Worksheets("BaseSheet").ListObjects("Table2") 
'Identify tables for copy job 
Set tbl3 = Worksheets("Step7Table").ListObjects("Step7") 
Set tbl4 = Worksheets("Step2Table").ListObjects("Table4") 

'Set to number of (districts -1) Currently 48 
For i = 0 To 9 

Dim districtName As Range 

With tbl3 

'Change Tables based on selected District from dropdown 
Worksheets("BaseSheet").Range("T1") =  Worksheets("BaseSheet").Range("U2").Offset(i, 0) 
Set districtName = Worksheets("BaseSheet").Range("T1") 
ThisFile = districtName.Value 

'Filter on selected district 
tbl3.Range.AutoFilter _ 
    Field:=1, _ 
    Criteria1:=districtName 


Dim rng As Range 
'Find size of copy table 
numRows = tbl3.DataBodyRange.Rows.SpecialCells(xlCellTypeVisible).Count 
numCols = tbl3.Range.Columns.Count 

'Resize table for paste 
tbl2.Resize tbl2.Range.Resize(numRows, numCols) 

tbl3.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy Destination:=tbl2 

End With 

Next i 

'Application.ScreenUpdating = True 
End Sub 

編集：範囲を取得してサイズを変更する方法を見つけられましたが、正しく機能していません。行の値が小さくなっても表は縮小されません。

Answer 1

コードの行

tbl2.Resize tbl2.Range.Resize(numRows, numCols) 

は、テーブルのサイズを変更するための私の最初の質問に答えました。最初にサイズを指定せずにテーブルのサイズを直接変更しようとしたため、最初は無効でした。私の2番目のエラーは、テーブルを縮小する "私自身のユーザーエラーでした。

テーブルは実際には小さくなっていましたが、前回の実行時のデータが残りました。これを変更するには、私は単に別のシートは以下の通りですからフィルタリングテーブルに基づいて、テーブルのサイズ変更を操作するための

.DataBodyRange.ClearContents 

完全なコードを追加する必要がありました。

Dim i As Integer 

Dim tbl As ListObject 
Dim tbl2 As ListObject 
Dim tbl3 As ListObject 
Dim tbl4 As ListObject 

'Identify tables for paste job 
Set tbl = Worksheets("BaseSheet").ListObjects("Table1") 
Set tbl2 = Worksheets("BaseSheet").ListObjects("Table2") 
'Identify tables for copy job 
Set tbl3 = Worksheets("Step7Table").ListObjects("Step7") 

'Set to number of (districts -1) Currently 48 
For i = 0 To 5 

Dim districtName As Range 
Dim ThisFile As String 

With tbl3 

'Change Tables based on selected District from dropdown 
    Worksheets("BaseSheet").Range("T1") =   Worksheets("BaseSheet").Range("U2").Offset(i, 0) 
    Set districtName = Worksheets("BaseSheet").Range("T1") 
    ThisFile = districtName.Value 

'Filter on selected district 
    Worksheets("Step7Table").Range("A1").AutoFilter _ 
     Field:=1, _ 
     Criteria1:=districtName 

'Find size of copy table 
    countRows = ((tbl3.DataBodyRange.Rows.SpecialCells(xlCellTypeVisible).Count/3) + 1) 
    'MsgBox (tbl3.DataBodyRange.Rows.SpecialCells(xlCellTypeVisible).Count)/3 

    numRows = countRows 
    'numCols = tbl3.DataBodyRange.Columns.Count 

'Resize table for paste 
    tbl2.Resize tbl2.Range.Resize(numRows) 

    tbl3.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy _ 
     Destination:=tbl2 

    'Add total row 
    tbl2.ShowTotals = True 
    tbl2.TotalsRowRange(, 1) = "Total" 
    'tbl2.TotalsRowRange(, 2).Formula = 
    'Call save functionality for each district 
    Call saveToExcel(ThisFile) 
    With tbl2 
    'Turn off total row for row resets. Currently counts as part of datarange 
     .ShowTotals = False 
    'Clear table so that is can be reformatted without leave legacy contents 
     .DataBodyRange.ClearFormats 
     .DataBodyRange.ClearContents 
    End With 
    'Turn off total row for row resets. Currently counts as part of datarange 

End With 

Next i 

'Enables alert messages 
Application.DisplayAlerts = True 
'Refresh screen after code runs fully 
Application.ScreenUpdating = True 
End Sub