|
こんにちは。
ステップ実行して、動くように手直ししてみました。
こんな感じでいいのでしょうか?
Sub ITEM別抽出マクロ_1()
Dim itemmax As Integer, i As Integer, maxcol As Integer
Dim tbl As Range, tblR As Range
Application.ScreenUpdating = False
With Sheets("メイン")
itemmax = WorksheetFunction.Max(.Range("a:a"))
' 最大のITEMナンバーの取得
maxcol = .Cells(9, 256).End(xlToLeft).Column
'最大列の取得
> 'Set tbl = .Range("A9", .Range("A65536").End(xlUp))
'↓
Set tbl = .Range("A10", .Range("A65536").End(xlUp))
'フィルターにかける範囲を設定
For i = 1 To itemmax
'1〜最大ITEMナンバーまで繰り返し作業する
ActiveSheet.AutoFilterMode = False
'フィルターモードの取り消し
tbl.AutoFilter
'範囲をフィルター設定
'Sheets("" & i & "").Cells.Clear
tbl.AutoFilter field:=1, Criteria1:="" & i & ""
'目的のデータを抽出
Set tblR = .Range(.Cells(9, 1), .Cells(.Range("a65536").End(xlUp).Row, maxcol))
tblR.Copy Destination:=Sheets("" & i & "").Range("a3")
'それをそれぞれのシートにコピー
> 'Cell.EntireColumn.AutoFit
'↓
Cells.EntireColumn.AutoFit
Rows("4:4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.RowHeight = 25
Range("B7").Select
ActiveWindow.Zoom = 75
Range("A1").Select
'セル列幅を整え 行高さ25、ズーム75%に設定
Next i
tbl.AutoFilter field:=1
End With
'追加↓
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
|
|