|
▼nokubo さん:
>早速ですが、ご質問させて頂きます。
遅ればせながら、ご発言させていただきます。
フィルタオプションで A列コード2桁を抽出して、
その2桁コードを条件にして、フィルタオプションで2桁コードのシートへ
抽出転記するサンプルです。
2桁コードの シートは 実行前には 存在しないもの仮定し、新規作成してます。
Sub Try1()
Dim myTable As Range, r As Range, c As Range
Dim x As Long, xplus As Long 'xは 表の列数 xPlusは 作業列番号(x + 1)
Dim rCopy As Range, CopyTo As Range
Dim ws As Worksheet
'転記元シートの元表 (1行目は見出し行とする)
With Worksheets("Sheet1")
Set myTable = .Cells(1).CurrentRegion
x = myTable.Columns.Count
xplus = x + 1
Set rCopy = .Range("AA1")
rCopy.CurrentRegion.Clear
End With
'テーブルの右隣りに A列「部品コード」の左2桁を書き出す
Set r = myTable.Columns(xplus)
With r
.Value = Application.Replace(myTable.Columns(1), 3, 10, "")
'2桁の種類を書き出す [BA列以降]
.AdvancedFilter xlFilterCopy, , rCopy, Unique:=True
End With
With rCopy
.CurrentRegion.Offset(2).Copy
.Offset(1, 1).PasteSpecial xlPasteValues, Transpose:=True
.CurrentRegion.Rows(1).Value = rCopy.Value
End With
'2桁のコードのシートを作成し、該当するものを一括コピー
For Each c In rCopy.CurrentRegion.Rows(1).Cells
Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = CStr(c.Item(2, 1).Value)
Set CopyTo = ws.Cells(1).Resize(, x)
CopyTo.Value = myTable.Rows(1).Value
myTable.Resize(, xplus).AdvancedFilter _
xlFilterCopy, c.Resize(2), CopyTo
Next
r.Clear
rCopy.CurrentRegion.Clear
End Sub
|
|