Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

21574 / 76738

←次へ　｜　前へ→


	【60557】Re:一つのシートから、複数のシートの作成

kanabun - 09/2/28(土) 0:51 -


	引用なし

	パスワード

▼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
　　
　　'転記元シートの元表（１行目は見出し行とする）
　　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列「部品コード」の左２桁を書き出す
　　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

1 hits

▼

【60551】一つのシートから、複数のシートの作成 nokubo 09/2/27(金) 16:12