エクセルマクロVBAについて

質問

エクセルマクロVBAについて、こんなこと出来ますか？

■A列からAS列の1行目にヘッダー情報をもつデータベース
■A列に担当者名

■A列にオートフィルタをかけて各担当ごとにデータを抽出したものを別シートに貼り付けて自動印刷したい

■担当者は都度変わるので、Criteria1:="ｘｘｘ"というようには直接書けない（担当名を自動で抽出したい）
■担当者の数も都度変わる

■補足 一行のデータを特定の雛形に転記する必要があるので別シートに出したいです

ちなみに、アナログで記録したコードは以下です。

Sub test1()

Sheets("データ抽出シート").Select
ActiveSheet.Range("$A$1:$AS$300").AutoFilter Field:=1, Criteria1:="山田"
Range("$A$1:$AS$300").Select
Selection.Copy
Sheets("抽出データ貼付シート").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SelectedSheets.PrintOut Copies:=1

Sheets("データ抽出シート").Select
ActiveSheet.Range("$A$1:$AS$300").AutoFilter Field:=1, Criteria1:="斉藤"
Range("$A$1:$AS$300").Select
Selection.Copy
Sheets("抽出データ貼付シート").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SelectedSheets.PrintOut Copies:=1

Sheets("データ抽出シート").Select
ActiveSheet.Range("$A$1:$AS$300").AutoFilter Field:=1, Criteria1:="田中"
Range("$A$1:$AS$300").Select
Selection.Copy
Sheets("抽出データ貼付シート").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SelectedSheets.PrintOut Copies:=1

End Sub

これ、担当者の抽出を自動でなんとかなりませんか？

回答No.5

hallo-2007

担当者という名前で別シートにデータを抽出して印刷したい
ということですね。オートフィルターのほかにフィルターオプションという機能が
エクセルにあります。
http://www.eurus.dti.ne.jp/~yoneyama/Excel/filter3.htm
などのサイトに説明が沢山あります。
かりにSheet1にデータがあって
Sheet2に
　　A　　　　B　　　C　　　　　D
１　担当者
２　山田
３
４　担当者　住所　電話番号　社員番号
５
と準備しておいてフィルタオプションの設定で
指定した範囲に　チェック
リストの範囲　Sheet1!$A:$D
検索条件の範囲　$A$1:$A$2
抽出範囲　　　$A$4:$D$4
で実行すれば　印刷したい希望のシートになるはずです。
それがうまくできたらマクロの記録を実行してみてください。
Sub Macro1()
Sheets("Sheet1").Columns("A:D").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("A4:D4"), Unique:=False
End Sub
とかになります。
さて次は
データ抽出するシート名（例では　Sheet2の）を右クリック　コードの表示でVBエディターを起動して
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
Sheets("Sheet1").Columns("A:D").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("A4:D4"), Unique:=False
End If
End Sub
を貼り付けます。
意味は　A2セルが変更されたら（抽出する担当者の名前を入れるセル）
フィルターオプションが実行されるようにしておけばA2セルに名前を入れるたびにデータが更新されます。
あとは
Sheet3に担当者名の一覧を準備して
Sub ボタン1_Click()
For i = 2 To Sheets("Sheet3").Range("A1000").End(xlUp).Row
Sheets("Sheet2").Range("A2").Value = Sheets("Sheet3").Range("A" & i).Value
Sheets("Sheet2").PrintPreview
Next
End Sub
するボタンを実行させると
フィルターオプションで抽出するシートの抽出条件（担当者）の名前が順に変わって印刷されます。
１　フィルターオプションの機能
２　マクロの記録（フィルターオプションをコード化）
３　シートのモジュールの　Cangeのイベントでコードが実行される
４　担当者の数だけ担当者名が変わるボタンを作成する
の４つほどの機能を勉強してみてください。
コピー＆ペーストを繰り返すよりシンプルかを思いますしパソコンの負担も少ないです。
担当者の一覧がなければ
紹介したサイトの下の方に重複しないデータの抽出方法が使えます。

回答No.4

end-u

>■担当者の数も都度変わる
仮に、抽出担当者を複数選択するのではなくて、全担当者を処理したい場合、
まずユニークな担当者リストを作ります。
これにはAdvancedFilter（[フィルタオプションの設定]）を使えば良いです。

With Sheets("データ抽出シート")
　　.Columns("AU").ClearContents
　　.Range("A1").CurrentRegion.Resize(, 1).AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　CopyToRange:=.Range("AU1"), _
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Unique:=True
End With
この場合、AU1が項目名なので、Loop処理範囲はAU2セルからになります。

ただし、全担当者処理なら
全てコピーして並び替え、担当者ごとに改ページ入れて一括印刷する方法もありかもしれません。

回答No.3

end-u

シートの『あるセル範囲』に抽出したい担当者名を入力して、
その範囲をLoopして処理すれば良いです。

Loop内で個々のセルの値をCriteriaにセットしAutoFilterで抽出、コピー、値貼り付け、印刷..という流れです。
抽出件数が0の場合の対策と、
直前の抽出件数の方が多かった場合を考慮した事前Clear処理なども必要ですね。

例えば、"データ抽出シート"のAU1セルに担当者を入力する場合のLoop処理サンプルは
Dim rng As Range
Dim r　 As Range
With Sheets("データ抽出シート")
　　Set rng = .Range("AU1", .Cells(.Rows.Count, "AU").End(xlUp))
　　For Each r In rng
　　　　MsgBox r.Value
　　Next
End With
Set rng = Nothing

..な感じになります。
実際には
>MsgBox r.Value
ここで
.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=r.Value
などのような処理をする事になります。

回答No.2

imogasi

>アナログで記録したコード
アナログとは何？マクロの記録のことか？アナログとは言わないだろう。
ーー
マクロの記録が
ActiveSheet.Range("$A$1:$AS$300").AutoFilter Field:=1, Criteria1:="山田"
Range("$A$1:$AS$300").Select
Selection.Copy
Sheets("抽出データ貼付シート").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks
と言うことか？質問に３つもコードを並べなくても良いだろう。
ーー
フィルタで毎回変えたい要求が起こる項目は（－＞自動で、といっても、変えたい以上は、毎回指定になるのはあたりまえだ。その方法は後述）
（１）検索データの範囲ーー　("$A$1:$AS$300"
（２）検索する語句ーー山田など
（３）貼り付け先ーーシート名
（３）貼り付け先ーー左上隅セル
これらをプログラムのなかでリテラル値になっているが、変数で（すべて文字列です）置き換えればしまい。
マクロの記録利用とともに始まる、常識的な課題である。
こういうことをはっきり認識していれば質問表現もガラッと変わるのでは。
ーー
（１）（３）（４）は
Sub test01()
Set x = Application.InputBox("範囲指定", Type:=8)
MsgBox x.Address
MsgBox x.Parent.Name
End Sub
をやってみて。
ーー
（２）は
テキストボックスでユーザーに指定させるか
InputBoxでユーザーに聞けば（指定させれば）良いのでは。
ーー
それにフィルタの結果について、編集ージャンプーセル選択ー可視セルーコピーー貼り付け
のコードをマクロの記録などで勉強すること。
単にSelection.Copy で旨くいくのかな？

回答No.1

tom04

こんにちは！

INPUTBOXを使って、担当を入力する方法はどうでしょうか？
一例ですがコードを載せておきます。

Sub test1()
Dim ws1, ws2 As Worksheet
Dim str As String
Set ws1 = Worksheets("データ抽出シート")
Set ws2 = Worksheets("抽出データ貼付シート")
処理1:
str = InputBox("担当者名を入力してください。")
If WorksheetFunction.CountIf(ws1.Columns(1), str) = 0 Then
If MsgBox("担当者が存在しません。" & vbCrLf & "再入力してください。", vbOKOnly) Then
GoTo 処理1
Else
GoTo 処理2
End If
End If
処理2:
ws1.Range("$A$1:$AS$300").AutoFilter Field:=1, Criteria1:=str
ws1.Range("$A$1:$AS$300").Copy
ws2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveWindow.SelectedSheets.PrintOut Copies:=1
ws2.Cells.Clear
ws1.AutoFilterMode = False
ws1.Range("A1").Select
End Sub

こんな感じではどうでしょう？m(__)m