エクセルVBAでできますか？

質問

以前ここでこんな質問をさせていただきました。
_________________________________＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
エクセルで台帳を作成するため、sheet1に次の通り情報を入力しました。
　　　A　　B　　　　C　　　　　D
1　日付　名前　　住所　　　申請事由　　
2　1/1 甲川　　東京都　　　　1
3 1/2　乙本　　大阪府 　 　 1
4 1/2　丙藤　　北海道 　 　2
5 2/1　甲山　　京都府 　　　 3
・　・ 　・　　・　　　　　　　　・
そして、sheet2に申請事項1の人の情報を、sheet3に申請事項2の人の情報を、sheet4に申請事項3の人の情報を空白を開けずに次の通り詰めて入力したいのです。

sheet2（申請事由1の人）
　　　 A 　　　　 B 　　　　 C
1　　日付　　名前　　 住所
2　　1/1 甲川　　東京都
3 　 1/2 乙本　　大阪府
4 ・　　　・　　　　・

sheet3（申請事由2の人）
　　　 A 　　　　 B 　　　　 C
1　　日付　　名前　　 住所
2　　1/2　　 丙藤　　北海道
3 ・　　　・　　　　・
4 ・　　　・　　　　・

sheet1に日付、名前等を入力しただけで、各事由事に他のsheetに詰めて入力されるよう関数式で入力することは可能かどうか教えてください。よろしくお願いします。
_______________________________＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
その際、関数でするやり方を教えてもらったのですが、（A3=IF(ROW(A1)>COUNTIF(Sheet1!$D$1:$D$100,$A$1),"",INDEX(Sheet1!A$1:A$100,SMALL(INDEX(SUBSTITUTE((Sheet1!$D$1:$D$100=$A$1)*1,0,10^5)*ROW($1:$100),),ROW(A1))))というやり方）何しろデータが10000件くらいあり、かなり処理速度が重いです。どなたかマクロで上記の処理の方法を教えていただけませんでしょうか？

回答No.3

imogasi · ベストアンサー

こんなの簡単だよ。ただし経験が相当ないと、思いつくという方法ではないかもしれない。
別シートに書き出すコードを経験ないと出来ないが。
（１）Sheet1の最下行を知る（定石コードがある。これを知らなければこの課題レベルは無理）
（２）最初データ行から終わりの行まで下記を繰り返す
（３）D列で今の行のデータが
　　１－－＞Sheet2
　　２ーー＞Sheet3
　　・・・
のようにプログラムの中に対応テーブルを作って、書き出すシートの
シート名を割り出す。
（４）割り出したシートの最終行を割り出し、その下にSheet1の今見てる行の、A,B,C列のデータを代入する。
ーー
何も難しいスキルを使わない。
Sub test02()
d = Worksheets("Sheet1").Range("A65536").End(xlUp).Row 'Sheet1の最下行
' MsgBox d
st = Array("", "Sheet2", "sheet3", "Sheet3") '番号とシート名の対応テーブル
For i = 1 To d '最下行まで繰り返し
For x = 1 To 2 '事由の数だけ探す
If Worksheets("Sheet1").Cells(i, "D") = x Then
dt = Worksheets(st(x)).Cells(65536, "A").End(xlUp).Row '書き出しシーとの最下行
Worksheets(st(x)).Cells(dt + 1, "A") = Worksheets("Sheet1").Cells(i, "A")
Worksheets(st(x)).Cells(dt + 1, "B") = Worksheets("Sheet1").Cells(i, "B")
Worksheets(st(x)).Cells(dt + 1, "C") = Worksheets("Sheet1").Cells(i, "C")
Else
End If
Next x
Next i
End Sub
ーー
例データ
Sheet1
日付　　名前　住所　　　　申請事由　　　　　　　　　
a1 b1 c1 1
a2 b2 c2 2
a3 b3 c3 1
a4 b4 c4 1
a5 b5 c5 2
a6 b6 c6 2
a7 b7 c7 1
a8 b8 c8 1
a9 b9 c9 2
Sheet2
a1 b1 c1
a3 b3 c3
a4 b4 c4
a7 b7 c7
a8 b8 c8
Sheet3
略
再テストするときは、Sheet2,Sheet3以下はクリアして行うこと。
そうしないと下へ下へ積み重なる。

お礼

回答いただきましてありがとうございます。imogasiさんにはいつもお世話になっております。教えてもらったとおりにやったら望むとおりにできました。ありがとうございました。

回答No.4

Wendy02

こんばんは。

単に数式が重いだけなら、貼り付けた後に、コピーして値貼り付けしても、同じだと思いますが、マクロを作ってみました。なお、実際は、Sheet1 に CommandButton をつければよいと思います。
なお、申請事由のデータは、数値のみのほうがよいです。文字列の場合は、空白を処理するオプションが必要です。また、1,000程度の振り分けでしたら、もっと可能だと思いますが、シートは、当面、上限は、40枚程度だと思ってください。本来は、シート名が気になりますが、それは、そのままにしておきます。

シートを開くときは、ハイパーリンクを、Sheet1 につけると良いと思います。

Sub DataClassify()
'-------------------------
　　'DataClassify
　　Dim r As Range
　　Dim shCnt As Variant
　　Dim mDataBase As Range
　　Dim CritDat As Variant
　　Dim i As Integer
　　Dim v As Variant

　　'臨時のクライテリアの出力のセル
　　'周辺にデータがないこと
　　Const Out As String = "AA1"

　　Application.ScreenUpdating = False
　　'シート名は変更してもよいですが、タブの位置が一番左端になくてはなりません。
　　With Worksheets("Sheet1")　
　　　　Set mDataBase = .Range("A1").CurrentRegion
　　　　Set r = mDataBase.Columns(4)
　　　　'ユニークデータの出力
　　　　r.AdvancedFilter _
　　　　Action:=xlFilterCopy, _
　　　　CopyToRange:=Range(Out), _
　　　　Unique:=True

　　　　'申請事由のデータ取得
　　　　CritDat = .Range(.Range(Out).Offset(1), .Cells(65536, Range(Out).Column).End(xlUp)).Value

　　　　'シートの数の確認
　　　　shCnt = UBound(CritDat, 1) + 1
　　　　If shCnt > Worksheets.Count Then
　　　　　　Worksheets.Add After:=Worksheets(Worksheets.Count), Count:=shCnt - _
　　　　　　Worksheets.Count
　　　　End If
　　　　.Select
　　　　'シートの内容のチェック
　　　　For i = 2 To Worksheets.Count
　　　　　　With Worksheets(i)
　　　　　　　　'一括で消してよい場合は、*の行を消し
　　　　　　　　'.Cells.ClearContents　だけ残す
　　　　　　　　If WorksheetFunction.CountA(.Cells) > 0 Then　'*
　　　　　　　　　　If MsgBox(.Name & " は、空のシートではありませんが、データを削除してよろしいですか？", vbOKCancel) = vbOK Then '*
　　　　　　　　　　　　.Cells.ClearContents　'これだけ残す
　　　　　　　　　　Else '*
　　　　　　　　　　　　MsgBox "マクロを中止します", 64 '*
　　　　　　　　　　　　GoTo Quit '*
　　　　　　　　　　End If '*
　　　　　　　　End If '*
　　　　　　End With
　　　　Next i
　　　　 'シート数の初期値
　　　　i = 1
　　　　'フィルタオプション
　　　　For Each v In CritDat
　　　　　　'数式の出力
　　　　　　.Range(Out).Offset(1, 1).FormulaLocal = "=D2=" & v
　　　　　　mDataBase _
　　　　　　.AdvancedFilter Action:=xlFilterCopy, _
　　　　　　CriteriaRange:=.Range(Out).Offset(, 1).Resize(2), _
　　　　　　CopyToRange:=Worksheets(i + 1).Range("A1"), _
　　　　　　Unique:=False
　　　　　　'ペーストした申請事由を消去
　　　　　　Worksheets(i + 1).Range("A1").CurrentRegion.Columns(4).ClearContents
　　　　　　i = i + 1
　　　　Next v
Quit:
　　　　.Range(Out).CurrentRegion.ClearContents
　　End With
　　Application.ScreenUpdating = True
　　Set r = Nothing
　　Set mDataBase = Nothing
End Sub

お礼

回答どうもありがとうございます。マクロでも色々やり方があるみたいですね。教えてもらったやり方についても勉強してみたいと思います。どうもありがとうございました。

回答No.2

kuma3f

思われていることと違っていましたらすみませんが、Sheet1で入力後、マクロでフィルタを使って振り分けされてはどうでしょうか。
参考までに次のコードでマクロに貼り付けて試してみてください。
元を壊してはいけないので、コピーした台帳で試してみてください。

Ａｌｔキー押しながらＦ８キーを押します。
　↓
マクロのダイアログが表示されたらマクロ名に自由に名前を入力してください。（例：振分）
　↓
名前を入力しましたら、「作成」をクリック
　↓
Microsoft Visual Basicの画面が開きますのでSub 振分()の下に次のコードをコピーして貼り付けてください。

Application.ScreenUpdating = False
Sheets("sheet2").Cells.ClearContents
Sheets("sheet3").Cells.ClearContents
Sheets("sheet4").Cells.ClearContents
'*** 申請事由1→Sheet2 ***
Sheets("Sheet1").Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=4, Criteria1:="1"
Cells.Select
Selection.Copy
Sheets("Sheet2").Select
Sheets("Sheet2").Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Sheet1").Select
Selection.AutoFilter
'*** 申請事由2→Sheet3 ***
Sheets("Sheet1").Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=4, Criteria1:="2"
Cells.Select
Selection.Copy
Sheets("Sheet3").Select
Sheets("Sheet3").Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Sheet1").Select
Selection.AutoFilter
'*** 申請事由3→Sheet4 ***
Sheets("Sheet1").Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=4, Criteria1:="3"
Cells.Select
Selection.Copy
Sheets("Sheet4").Select
Sheets("Sheet4").Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Sheet1").Select
Selection.AutoFilter
Application.ScreenUpdating = True
Sheets("Sheet1").Range("A1").Select
MsgBox "振り分けが完了しました。"

'****コピー貼り付けはここまで ****

Microsoft Visual Basicの画面を×で閉じます。
使い方は、Ａｌｔキー押しながらＦ８キーを押します。
マクロのダイアログが表示されるので先ほど名前を付けたマクロを選択して「実行」をクリック。
（選択されている状態でしたら、そのままＥｎｔｅｒキーで実行されます。）
各シートに抽出されていると思います。

お礼

回答どうもありがとうございます。マクロでも色々やり方があるみたいですね。教えてもらったやり方についても勉強してみたいと思います。どうもありがとうございました。

回答No.1

izmlz

抽出先のシートで、[フィルタオプションの設定]をすれば良いかと思います。
詳しくは以下のページをご覧ください。

エクセル技道場－別シートにデータを抽出
http://www2.odn.ne.jp/excel/waza/edit.html#SEC37

なお、同じシートで抽出するのなら、[オートフィルタ]ボタンをメニューバーあるいはツールバーに登録しておけば簡単です。↓をご覧ください。

http://www2.odn.ne.jp/excel/waza/edit.html#SEC19

参考URL：

http://www2.odn.ne.jp/excel/waza/edit.html#SEC19

お礼

回答いただきましてありがとうございます。関数やVBAにこだわっていましたが、フィルタオプションを使えばもっと楽にできることがあるのですね。勉強になりました。ありがとうございます。