EXCELのマクロについて

質問

EXCELのマクロについて質問させてください。
一覧シートから、職種別の各シートへ集計（貼り付け）が出来るような
プログラムを作成したいのでやってみたところ、私の知識では上手く出来ませんでした。
お力をお借り出来ると幸いです。

具体的には、一覧シートへ入力後（毎月入力）
『A』　『B』　『E』と分かれた職種別の各シートへ職種別かつ氏名の昇順でソートが掛かった状態で
貼り付け？集計？が出来るようにしたいです。

一覧シートのB列には「A・B・E」のどれかの職種が入力されており
氏名はD列E列へ記載しています。（漢字、カナ表示）
A～AD列までデータを記入していますので、全て各シートへ集計出来ると嬉しいのですが・・・
行は8行目から記載してます。
上記のようにプログラムを組む事は可能でしょうか。

具体的なプログラムも載せて頂けると嬉しいです。
宜しくお願い致します。

回答No.3

tom04 · ベストアンサー

続けてお邪魔します。

（1）について・・・
前回のコードは7行目の項目が最終列まで空白セルなしに入っているという前提のコードでしたので
途中に空白セルがあると連続しているセルまでしか表示されないと思います。

（2）の
＞Ａ、Ｂ、Ｅ以外に職種が増えてしまった場合は
＞どうしたらいいでしょうか・・・

「一覧」Sheetにデータ追加があり、「職種名」のSheetがない場合は新たにSheetを追加して
同じ操作をするようにしてみました。
前回のコードは削除して↓のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。
尚、「一覧」Sheetはシート見出しの一番左側に配置してあるとします。

Sub Sample2()
Dim i As Long, k As Long
Dim lastRow As Long, lastCol As Long, endRow As Long, endCol As Long
Dim str As String, wS As Worksheet, myFlg As Boolean
Application.ScreenUpdating = False
With Worksheets("一覧")
.Activate
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
lastCol = .UsedRange.Columns.Count
endCol = lastCol + 1
Range(.Cells(7, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, _
copytorange:=.Cells(1, endCol), unique:=True
For i = 2 To Cells(Rows.Count, endCol).End(xlUp).Row
str = .Cells(i, endCol)
For k = 2 To Worksheets.Count
If Worksheets(k).Name = str Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = str
End If
Set wS = Worksheets(str)
wS.Cells.Clear
.Rows(7).AutoFilter field:=2, Criteria1:=str
If .Cells(Rows.Count, "B").End(xlUp).Row > 7 Then
Range(.Cells(7, "A"), .Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
endRow = wS.Cells(Rows.Count, "B").End(xlUp).Row
Range(wS.Cells(1, "A"), wS.Cells(endRow, lastCol)).Sort key1:=wS.Range("D1"), order1:=xlAscending, Header:=xlYes
wS.Columns.AutoFit
End If
myFlg = False
Next i
.AutoFilterMode = False
.Columns(endCol).Delete
End With
Application.ScreenUpdating = True
End Sub

こんなんではどうでしょうか？m(_ _)m

お礼

昨日に引き続き、ありがとうございます。
教えて頂いたプログラムで無事に作成できました。
本当にありがとうございました！
これでいいデータ集計が出来そうです。
他の場面でも使えそうですので参考にさせて頂きたいと思います^^
また何かあれば、ぜひ宜しくお願い致します。

回答No.2

tom04

No.1です。

エラーが出たというコトですが、
今考えられる原因
（1）標準モジュールになっているか？
もしかしてシートモジュールになっていませんか？
Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に前回のコードをコピー＆ペーストする。

（2）Sheet名は正しいか？
前回のコードは　一覧・A・B・E　←　A・B・Eは半角
というSheetが存在する！という前提のコードです。
Sheet名が全角になっていたり、余計なスペースが入っているとエラーになります。

ん～～～
今考えられる原因としてはこのくらいですが・・・
他の原因ならごめんなさい。m(_ _)m

お礼

No.1様
お忙しい中度々のご回答ありがとうございます。
私なりにやってみた結果、無事に集計が取れました！
本当にありがとうございました。
それと２点ばかり追加でのご質問なのですが・・・

１.各シート（Ａ、Ｂ、Ｅ）へ集計を取った際に
「一覧」シートの【職種、氏名、カナ】等の項目も同時にマクロで表示させることは可能ですか？？

２.Ａ、Ｂ、Ｅ以外に職種が増えてしまった場合は
どうしたらいいでしょうか・・・。
増やした場合同じように集計が取れるようにしたいです。

追加追加の質問で申し訳ありません・・・。
お手数ですが宜しくお願い致します。

回答No.1

tom04

こんにちは！

＞行は8行目から記載してます
というコトですので、↓の画像のように7行目は項目行で8行目からデータがあるとします。

＞氏名はD列E列へ記載しています。（漢字、カナ表示）
E列の「カナ」で並び替えています。

標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim k As Long, wS As Worksheet, myArry
Set wS = Worksheets("一覧")
myArry = Array("A", "B", "E")
For k = 0 To UBound(myArry)
With Worksheets(myArry(k))
.Cells.Clear
wS.Range("A7").AutoFilter field:=2, Criteria1:=myArry(k)
If wS.Cells(Rows.Count, "B").End(xlUp).Row > 7 Then
wS.Range("A7").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy .Range("A1")
.Range("A1").CurrentRegion.Sort key1:=.Range("E1"), order1:=xlAscending, Header:=xlYes
.Columns.AutoFit
End If
End With
Next k
wS.AutoFilterMode = False
End Sub

※　「一覧」Sheetの変更があるたびにマクロを実行してみてください。
こんな感じではどうでしょうか？m(_ _)m

お礼

ご回答ありがとうございました。
早速やってみたのですが、私が無力なのか上手く出来ませんでした（汗）
「４００」とエラーが出てしまい、「一覧」シートが職種Ａのみの表示となってしまいました。
ご回答頂いたかいあって名前順のソートは出来ているようです。
何が原因なのでしょうか（汗）
現在は「一覧、Ａ、Ｂ、Ｅ」の４つのシートが入っており
「一覧」以外は空白の状態です。
目標としては、マクロ実行後Ａ、Ｂ、Ｅの各シートへ職種別かつ名前順で集計出来るようにしたいのですが・・・
大変お手数ですが、併せてご検討頂けますでしょうか。
宜しくお願い致します。