EXCEL：抽出・シートに分散させる方法2

質問

いつもお世話になってます。

http://oshiete1.goo.ne.jp/kotaeru.php3?q=1430444

で質問させていただいた者です。
たくさんご回答をいただき、No.13の方の方法で何とか目的の物を作ることが出来たのですが、
計算式が多いためか、処理に時間がかかってしまい、困っています。
大変勝手なのですが、どなたかこれをマクロ化してはいただけないでしょうか・・。

よろしくお願いします。

回答No.5

Wendy02

こんばんは。

＞複数条件で抽出して、指定したセルに貼り付けをすることにはどのようにしたらいいでしょうか？

それは、私のマクロでは、第二検索値(Criteria2） に、入れて上げさえすれば可能です。

ただ、みなさんのマクロをお試しになったご様子がありませんね。また、印刷用で、という理由でシートにデータを振り分けしてしまうというのは、賛成できません。印刷用にするのは、テンポラリシートにして、印刷するときだけ、そのデータを出力したほうがよいです。いわゆるデータベースとしての使い方です。

＞例えば　担当・商品名　（実際はもっと細かい振り分け方をしたい）ごとに一まとめにしたい（複数条件で抽出）場合はどのようにしたらいいのかと

もし、それをこれ以上、細分化し、シート別に振り分けたら、それは管理的にも大変です。できれば、オートフィルタで、そのままの場所で選り分けたほうが簡単かもしれません。また、フィルタオプションを使用してもよいかもしれません。

お礼

印刷用として振り分けしたいのには、この元データから抽出した内容の他に、手動でも入力しなければならない項目があるからなのです。

他の仕事が入って来てしまってなかなか進められていませんが、
教えていただいた方法を試させて頂いてまた報告させて頂きます。

ありがとうございました。

回答No.4

fly_moon

>複数条件で抽出して、指定したセルに貼り付けをすることにはどのようにしたらいいでしょうか？

?????どういうことですか?????

この説明では複数条件で抽出しているようにみえないのですが。ただ、データの表示順序がまずは右に行き、2件になると又、下のはじめの位置(左)に行っただけに見えますが。

補足

説明足らずですみません・・。

リストの中から、まず担当者別にシート分けするのですが、
担当者ごとのシートは印刷用なので、罫線・書式などがあらかじめ設定されており、
項目ごとに振り分けなければならないセルが決まっています。

>複数条件で抽出して、指定したセルに貼り付けをすることにはどのようにしたらいいでしょうか？

例えば　担当・商品名　（実際はもっと細かい振り分け方をしたい）ごとに一まとめにしたい（複数条件で抽出）場合はどのようにしたらいいのかと
お聞きしたつもりだったのですが、わかりにくかったようで申し訳ありませんでした。

回答No.3

Wendy02

こんばんは。
何人も、同じようなものを作っても意味がありませんが、一応、出来てしまいましたので、掲示しておきます。

現在のマクロは、積み上げ式にデータを増やしていくものではありませんが、修正は可能です。コピー先のデータは、一旦削除されます。このマクロの出力スピードは非常に速いはずです。

担当者のシートがない場合は、自動的に加えらてから、コピーされます。

'<標準モジュール>
Sub PickupSort()
　Dim Rng As Range
　Dim UniqData As Range
　Dim crt As Object
　Dim i As Long, d As Long
　i = 1
　With ActiveSheet
　　Set Rng = .Range("A1", .Range("A65536").End(xlUp).Offset(, 3))
　　'ユニークデータの取得
　　Rng.Columns(2).AdvancedFilter Action:=xlFilterCopy, _
　　　　CopytoRange:=.Cells(1, 256), Unique:=True
　　Set UniqData = .Range(.Cells(1, 256), .Cells(1, 256).End(xlDown))
　　'オートフィルター
　　For Each crt In UniqData.Offset(1).Resize(UniqData.Rows.Count - 1)
　　　Rng.AutoFilter Field:=2, Criteria1:=crt.Value
　　　'シートのチェック
　　　On Error Resume Next
　　　d = Worksheets(crt.Value).Index
　　　If Err() > 0 Then
　　　　Worksheets.Add After:=Sheets(Sheets.Count)
　　　　Worksheets(Sheets.Count).Name = crt.Value
　　　End If
　　　Err.Clear
　　　On Error GoTo 0
　　　'コピー先のデータを一旦消す
　　　Worksheets(crt.Value).Cells.ClearContents
　　　'データのコピー
　　　Rng.Copy Worksheets(crt.Value).Range("A1")
　　　'2列目削除
　　　Worksheets(crt.Value).Columns(2).Delete
　　　i = i + 1
　　Next crt
　End With
　UniqData.ClearContents
　Rng.AutoFilter
　Set Rng = Nothing: Set UniqData = Nothing
End Sub

補足

ご回答ありがとうございます。

例えば 「Sheet 佐藤」を、

行1 顧客名(列A)　　商品名(列C)　　金額(列D)　　　顧客名(列G)　　商品名(列I)　　金額(列J)
行2 Ａ社　　　　　　　　バナナ　　　　　100　　　　　　　Ａ社　　　　　　　　リンゴ　　　　　200
行3 Ａ社　　　　　　　　バナナ　　　　　300

のように、複数条件で抽出して、指定したセルに貼り付けをすることにはどのようにしたらいいでしょうか？

回答No.2

fly_moon

私も作ってみました。もう先にご返答あったのですが、作ってしまっていたのですいません。

'コピー開始======================================
Sub 担当者別シート作成()

'設定開始-------------------------------------------------------------------------

'担当者名の入っている列を指定
Const tantoCol As String = "B"

'コピーしたい列を,で区切って指定(担当者ごとのシートの列の順番)
Const copyCol As String = "A,C,D"
'-------------------------------------------------------------------------設定終了
Dim st As Worksheet
Set st = ActiveSheet
Dim r As Long
Dim cc
cc = Split(copyCol, ",")

Dim tantosya As String
Dim TantoSheet As Worksheet
Dim tr As Long

On Error GoTo NewSheet
For r = 2 To st.Range("A65536").End(xlUp).Row
tantosya = st.Range(tantoCol & r).Value
Set TantoSheet = Sheets(tantosya)
tr = TantoSheet.Range("A65536").End(xlUp).Offset(1).Row ' + 1

For i = LBound(cc) To UBound(cc)
TantoSheet.Cells(tr, i + 1).Value = st.Range(cc(i) & r).Value
Next

Next

Exit Sub

NewSheet:
Sheets.Add.Name = tantosya
Set TantoSheet = Sheets(tantosya)
For i = LBound(cc) To UBound(cc)
TantoSheet.Cells(1, i + 1).Value = st.Range(cc(i) & "1").Value
Next
Resume Next

End Sub
'コピー終了======================================

もし使っていただけるなら、設定開始から設定終了までを環境にあわせて設定してください。

注※データのあるシートをアクティブにしてから行ってください。

at121さん出過ぎたまねですいません。

補足

ご回答ありがとうございます。

例えば 「Sheet 佐藤」を、

行1 顧客名(列A)　　商品名(列C)　　金額(列D)　　　顧客名(列G)　　商品名(列I)　　金額(列J)
行2 Ａ社　　　　　　　　バナナ　　　　　100　　　　　　　Ａ社　　　　　　　　リンゴ　　　　　200
行3 Ａ社　　　　　　　　バナナ　　　　　300

のように、複数条件で抽出して、指定したセルに貼り付けをすることにはどのようにしたらいいでしょうか？

回答No.1

at121

アクティブの　シート　（リスト）

顧客名　　担当者　　商品名　　金額
Ａ社　　　佐藤　　　バナナ　　100

を　 B列　担当者で各項目を　担当者シートごとに振り分け
　　　・担当者シートが無いときは担当者シートを一番前に作成
　　　・担当者シートがあるときは　下に追加

Sheet 佐藤

顧客名　　商品名　　金額
Ａ社　　　バナナ　　100

　　※・・　日付の項目が無いのは・・　　使えないかも・・　
　　　　　　日付の項目を追加することを勧めます。

↓　標準モジュールにコピー　↓

Sub 担当者シート別に振り分け()

Set リスト = ActiveSheet

For Each 担当者 In リスト.Columns(2).SpecialCells(xlCellTypeConstants)
If 担当者.Row <> 1 Then '見出し行はスキップ

'既存の担当者シート　が無い場合は　新しいシート作成
On Error Resume Next
Application.DisplayAlerts = False
Sheets(Trim(担当者.Value)).Select
If Err Then
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = Trim(担当者.Value)
Range("A1:C1") = Split("顧客名/商品名/金額", "/") '見出し設定
End If
Application.DisplayAlerts = True
On Error GoTo 0
Set 置き場所 = Range("A65536").End(xlUp).Offset(1)
置き場所.Offset(0, 0) = 担当者.Offset(0, -1) '顧客名
置き場所.Offset(0, 1) = 担当者.Offset(0, 1) '商品名
置き場所.Offset(0, 2) = 担当者.Offset(0, 2) '金額

End If
Next

リスト.Select

End Sub

補足

ご回答ありがとうございます。

例えば 「Sheet 佐藤」を、

行1 顧客名(列A)　　商品名(列C)　　金額(列D)　　　顧客名(列G)　　商品名(列I)　　金額(列J)
行2 Ａ社　　　　　　　　バナナ　　　　　100　　　　　　　Ａ社　　　　　　　　リンゴ　　　　　200
行3 Ａ社　　　　　　　　バナナ　　　　　300

のように、複数条件で抽出して、指定したセルに貼り付けをすることにはどのようにしたらいいでしょうか？