VBAでソートして、貼り付けのやり方

質問

（条件及び操作）
１　シートが２つあります。(元データ　と　名簿シート）という名前。
２　名簿シートのH２に数字を入力する。元データのシートの１行目にある、番号と一致する列を操作する。
３　元データの対象の列で、まずD列（組ごと）に、１組・２組をソートする
４　次に、対象の列（科目：国語や理科など）事に、○をソートする
５　ソート後に、番号、名前、出身と○をコピーする。
６　その後、名簿シート（１組でソートしたものは、B２、２組でソートしたものはE２）に貼り付ける
７　対象の列の科目名（国語なら国語を）をA１に貼り付ける
８　元データのソートを解除する

（備考）
番号も科目も１００ぐらいあります。

これらの（条件及び操作）を元に、名簿シートのH2に任意の数字を入力して、元データの対象の列を上記（１～８）の操作を行いたいと思います。

《シート名：元データ》
A列　　　B列　　　C列　　　D列　　　E列　　　F列　　　G列　　　H列　　　I列　　 ・・・
　　　　　　　　　　　　　　　　　　　　　　１　　　　２　　　　　３　　　　　４　　　　５　　　・・・　　
番号　　名前　　　出身　　組　　　　国語　　理科　　　英語　　　数学　　社会　　・・・
００１　Aさん　　東京　　　 １　　　　　○　　　　　　　　　　　　　　　　○　　　○　
００２　Bさん　　沖縄　　 １　　　　　○　　　　　　　　　　　　　　　　　○　　　○　
００３　Cさん　　鹿児島　　１　　　　　○　　　　　　　　　　　　　　　　　　　　　○　
００４　Dさん　　青森　　 　１　　　　　○　　　　　　　　　　　　　　　　　　　　　○　
００５　Eさん　　北海道　　２　　　　　○　　　　　　　　　　○　
００６　Fさん　　京都　　　２　　　　　○　　　　　　　　　　○　　　　　○
・
・
・

《シート名：名簿シート》　　　　　
A列　　　B列　　　C列　　　D列　　　E列　　　F列　　　G列　　　H列　　　
国語
　　　　１組　　　　　　　　　　　　　　２組
　　　　番号　　　名前　　　出身　　番号　　　名前　　　出身　　番号入力

お忙しい中、大変申し訳ございませんが、どうぞよろしくお願いします。
また、質問の内容などがわかりづらいなどの事がありましたら、ご指摘ください。

回答No.2

keithin · ベストアンサー

○列をコピーする，というご説明が図に反映されていませんので反映します。
これに伴い，番号記入セルはＨ２からＪ２に移動します。
簡単化の為，名簿シートの１行目はご説明通り１，２，３…の連番で記入してあるとします。
もしもホントは別の何か記号だったときは，適宜検索関数で位置を検出して下さい。

手順：
名簿シートのシート名タブを右クリックしてコードの表示を選び，
現れたシートに下記をコピー貼り付ける

private sub Worksheet_Change(byval Target as excel.range)
　dim targetrange as range
　dim c0 as long, c1 as long, c2 as long, cc as long

　if target.address <> "$J$2" then exit sub
　if target = "" then exit sub

　with worksheets("元データ")
　cc = .range("IV2").end(xltoleft).column - 4
　if target.value > cc then exit sub
　c0 = .range("A65536").end(xlup).row - 2
　c1 = application.countif(.range("D:D"), 1)
　c2 = c0 - c1

　activesheet.usedrange.offset(2).entirerow.delete
　set targetrange = .range(.range("A2"), .cells(c1 + 2, .range("IV2").end(xltoleft).column))
　targetrange.sort _
　　key1:=.range("D2"), _
　　order1:=xlascending, _
　　key2:=.range("D2").offset(0, target.value), _
　　order2:=xlascending, _
　　header:=xlyes

　range("B3:D" & c1 + 2).value = .range("A3:C" & c1 + 2).value
　range("E3:E" & c1 + 2).value = .range("D3:D" & c1 + 2).offset(0, target.value).value
　range("F3:H" & c2 + 2).value = .range("A3:C" & c2 + 2).offset(c1, 0).value
　range("I3:I" & c2 + 2).value = .range("D3:D" & c2 + 2).offset(c1, target.value).value
　range("A1,E2,I2").value = .range("D2").offset(0, target.value).value

　targetrange.sort _
　　key1:=.range("A2"), _
　　order1:=xlascending, _
　　header:=xlyes
　end with

end sub

Ｊ２に番号を記入する。
勝手にデータが表示される。

お礼

keithin　様

いつもお答えしていただき、誠にありがとうございます。

ただ、作成していただいたマクロでは、名簿シートに２組は望み通りの形にはなったのですが、１組のデータが貼り付けられません。
また、元データがまったく別のデータの並びになってしまいす。

回答No.10

tom04

こんにちは！
何度も失礼します。

keithinさんの方法で解決したようで良かったです！

VBAのコードはこれでないとダメ！ということはありませんので、とりあえず希望の動きになれば良いと思います。
他の方のコードの記述方法を見ると、色々な考え方があるのだなぁ～！と思えるようになります。

尚、今後のためにコードの意味を把握して、ご自身でコードの修正ができるようになることがベストだと思います。

当方が投稿したコードはこちらで勝手に表を作成し、一応動いたことを確認した上でのコードでしたが、
微妙にレイアウト等が違っていたのかもしれませんね。

いずれにしても解決して一安心です。
ではでは・・・m(__)m

お礼

tom04 様

お返事遅くなりました。年度末は忙しくて・・・

この度は本当にありがとうございました。
まだまだ、初心者で質問の仕方一つろくに出来ない中、やさしく対応してくれた事が、
とてもうれしく、そして癒されました。

教えていただいた、マクロを元に今後も勉強していきたいと思います。
感謝です。

回答No.9

yy_kd

No1 yy_kd です。　失礼しました。修正済みですので、もう一度トライしてみてください。

回答No.8

keithin

ご質問で不明瞭な点が，イチイチ寄せられた回答が上手く動かない原因になっていると推測されます。

○各シートで，正確に何行何列に何が入っているのか。
　1.先に指摘した「○列」貼り付けの説明が不整合な事と，それに伴いH2かJ2かの間違い。
　2.ご質問で掲示された元データが，そもそも何行から始まっているのかの説明が無い事。
　3.ご質問では名簿の「２行目に貼り付けたい」となっているが，図では３行目のようでもあり，また「貼り付けたい」の主語が抜けているので「４行目」のようでもある事。

○各列に何が入っているのか
　4.ご相談の例示では元データのＡ列が１，２，３…の順番に並べてあるように書かれているが，どうやらそうではないらしい事。
　5.ご相談の例示では元データのＡ列が１，２，３と数字で記入されているように書かれているが，もしかすると数式がもっと沢山記入されている可能性がある事。
　6.ご相談の例示では組列に数字で（半角英数の数値として）1と2が入っていると読めるが，もしかすると違うかも知れない事。
　7.先に指摘しましたが，元データの１行目には本当に１，２，３と入っているのかも不明な事。

回答したマクロは
　１→○列をコピーします。番号記入はＪ２列です　
　２→元データは１行目が番号，２行目がタイトル行，３行目から名簿の実データです
　　　Ａ列が番号列，Ｄ列が組列です
　３→名簿シートは２行目がタイトル行，３行目からコピーした名簿の実データです
　　　Ｂ列とＦ列が番号列，Ｃ・Ｇ列が名前列，Ｄ・Ｈ列が出身列，Ｅ・Ｉ列が○列です
　４→元データはＡ列に１，２，３と昇順で記入されているのが「正しい並び」です
　５→元データのＡ列は，実際にデータがある下端行までに生数字で記入してあり，それより下の空の行に数式などは残っていません
　６→元データのＤ列は，半角数字の1または2が記入されています
　７→元データの１行目は使っていませんが，名簿のＪ２に記入するのは半角の数字で１，２，３です
という作表に対応するように書いてあります。
まずはあなたのお手許の元データと名簿シートを，この通りになるように手直ししてからマクロを作動させてみて下さい。

結局こういった大前提となるシートのレイアウト（何列何行に何が入っている）が何か一つズレただけで，みんなが考えてくれたマクロはほとんどが無駄作業になります。
皆さんのマクロを解析して自分で直せるなら構いませんが，コピーしてそのまま実行するしか出来ないのでしたら，せめて最初の情報提供は可能な限り正しい姿でお願いします。

＃しかし，いったいどこをどう間違えたら「１組が全然コピーされず２組は正しくコピーされた」なんて状態が起こるのか，手元でいくつか試してみましたが再現する事はできませんでした。
　繰り返しになりますがあなたの情報提供が具体的に正確なら，こういった食い違いも避けられたと思います。

お礼

keithin　様

毎回、ご回答していただき、誠にありがとうございます。
そして、毎回keithin様の誠意あるご回答にも気持ちよく終わらせる事が出来ないことが
誠に心苦しい限りです。

今回ご指摘があったように、質問の出し方（次回からは、tom04様が出してくれたように）
画像を利用して質問をしていきたいと思います。

このたびは誠にありがとうございます。

追伸
再度、名簿シートを作成しなおしてkeithin様が作成していただいたマクロを実行したところ、うまく作動しました。

今回は、誠にありがとうございました。

回答No.7

tom04

何度もごめんなさい。

＞エラーこそ出ませんが、まったく反応しません。・・・

で引っ掛かりましたのでまたまたお邪魔します。

投稿した画像の「名簿シート」の3行目までの黄色いセル（○組）・ベージュのセル（番号・名前・・・）はあらかじめ入力してある前提でのコードですので、
もしこのデータがないと全く反応しないと思います。

もちろん列も1列違うだけで全く滅茶苦茶な表示になると思いますので、今一度前回投稿した画像の配置でマクロを試してみてください。

それでもダメならごめんなさいね。m(__)m

お礼

tom04　様

たびたびのご回答ありがとうございます。
誠に誠に勝手ではありますが、明日は朝早く（５時起き）でありますので、ご指摘のところは明日以降チェックしてみようと思います。
なので、明日の夜（おそらく２２時過ぎ・・・）に再度チェックして、結果をお伝えしたいと思います。

もしよろしければ、それまでお待ちいただければと思います。大変大変申し訳ございません。

失礼します。

補足

補足でご挨拶させていただきます。
昨日は大変お世話になりました。

家に帰ってから、tom04様が作成されたマクロを再度実行してみました。
（NO.3）の画像をもとに、再度一から作成もしましたが・・・
思うように動きませんでした。。。もう、さっぱりわかりません。。。

昨日は、夜遅くまでVBAを作成していただきまことにありがとうございました。
また、他の方もご指摘があったように、今後は皆様にもわかりやすいように質問も考えて
いきたいと思います。

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

回答No.6

tom04

No.5です

補足に
＞名簿シートのH2（正確にはJ２）に数字を入力して、元データの対象の列を、名簿シートに貼り付けたいと思っております・・・
とありましたので、J2セルに科目の番号を入力した後のコードをもう一度載せてみます。

尚、Sheetの配列は前回の画像通りとします。

Sub test() 'この行から
Dim ws1, ws2 As Worksheet
Dim i, j, k As Long
Set ws1 = Worksheets("元データ")
Set ws2 = Worksheets("名簿シート")
k = ws2.UsedRange.Rows.Count
If k >= 4 Then
ws2.Rows(4 & ":" & k).ClearContents
End If
j = WorksheetFunction.Match(ws2.Cells(2, 10), ws1.Rows(1), False)
For i = 3 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(i, j) = "○" Then
If ws1.Cells(i, 4) & "組" = ws2.Cells(2, 2) Then
With ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 1)
.NumberFormatLocal = "000"
.Offset(, 1) = ws1.Cells(i, 2)
.Offset(, 2) = ws1.Cells(i, 3)
End With
ElseIf ws1.Cells(i, 4) & "組" = ws2.Cells(2, 5) Then
With ws2.Cells(Rows.Count, 5).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 1)
.NumberFormatLocal = "000"
.Offset(, 1) = ws1.Cells(i, 2)
.Offset(, 2) = ws1.Cells(i, 3)
End With
End If
End If
Next i
i = ws2.Cells(Rows.Count, 2).End(xlUp).Row
j = ws2.Cells(Rows.Count, 5).End(xlUp).Row
ws2.Range(Cells(4, 2), Cells(i, 4)).Sort key1:=ws2.Cells(4, 2), order1:=xlAscending
ws2.Range(Cells(4, 5), Cells(j, 7)).Sort key1:=ws2.Cells(4, 5), order1:=xlAscending
End Sub 'この行まで

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

回答No.5

tom04

No.3です！

前回のコードで2か所誤りがありました。
k = ws2.UsedRange.Rows.Count
の次の行を

If k >= 4 Then
ws2.Rows(4 & ":" & k).ClearContents
End If

に変更してください。

それと最後の2行

ws2.Range(Cells(4, 2), Cells(k, 6)).Sort key1:=ws2.Cells(4, 2), order1:=xlAscending
ws2.Range(Cells(4, 5), Cells(k, 7)).Sort key1:=ws2.Cells(4, 5), order1:=xlAscending

を

i = ws2.Cells(Rows.Count, 2).End(xlUp).Row
j = ws2.Cells(Rows.Count, 5).End(xlUp).Row
ws2.Range(Cells(4, 2), Cells(i, 4)).Sort key1:=ws2.Cells(4, 2), order1:=xlAscending
ws2.Range(Cells(4, 5), Cells(j, 7)).Sort key1:=ws2.Cells(4, 5), order1:=xlAscending

に変更してください。
前回のコードではちゃんと表示されないと思います。
何度も失礼しました。m(__)m

お礼

tom04　様

補足説明ありがとうございます。

＞＞「名簿シート」のA1に「科目」を入力するということなので、H2セルは必要ないように思われます。

説明が悪くて申し訳ございません。
自分が作成したいマクロとしては、名簿シートのH2（正確にはJ２）に数字を入力して、元データの対象の列を、名簿シートに貼り付けたいと思っております。

ただ、教えていただいたマクロでは、エラーこそ出ませんが、まったく反応しません。

回答No.4

imogasi

質問者は初心者なのだろうが、ここには「マクロの記録」というものが触れられていない。
初心者は、わかりにくい文章で丸投げせず、まず質問者が手動で操作をやって（当然決った１通りの場合だが、まずは、それで良いのだ）マクロの記録を取り、コードをジックリながめて、考えること。
本質問では、課題丸投げではないか。
ーー
そしてコード上で、別の場合だと、
●何処の個所が変わる可能性があるか、を考えること。
●其れで現在の形から、一般化したらコードはどうなるか、考える
そのステップで考えて、判ら無ければ、ここに質問する手もあるだろう。
そうすると疑問点がはっきりするし、どういう風に考えるべきか勉強になるのだ。
場合によって変えるべき個所は２，３箇所が多いのではないかな。

お礼

imogasi　様

お返事遅くなってすみません。
ご指摘、ありがとうございます。

教えていただいたことは、今後真に受け止めて今後とも精進していきたいと思います。

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

回答No.3

tom04

こんばんは！
質問内の
＞８　元データのソートを解除する
の部分に関してですが、VBAで並び替えを行ってしまうと元に戻せないと思いますので、
「元データ」Sheetには手をつかない方法のVBAです。
（元に戻せない　←に関して間違っていたらごめなさい。）
それから、各科目ごとにSheetがあるわけでなく、「名簿シート」がありその科目を変更した後にマクロを実行すれば良いわけですよね？
一応そういうことだとして・・・
↓の画像のように「名簿シート」のA1に「科目」を入力するということなので、H2セルは必要ないように思われます。

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

Sub test() 'この行から
Dim ws1, ws2 As Worksheet
Dim i, j, k As Long
Set ws1 = Worksheets("元データ")
Set ws2 = Worksheets("名簿シート")
k = ws2.UsedRange.Rows.Count
ws2.Rows(4 & ":" & k).ClearContents
j = WorksheetFunction.Match(ws2.Cells(1, 1), ws1.Rows(2), False)
For i = 3 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(i, j) = "○" Then
If ws1.Cells(i, 4) & "組" = ws2.Cells(2, 2) Then
With ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 1)
.NumberFormatLocal = "000"
.Offset(, 1) = ws1.Cells(i, 2)
.Offset(, 2) = ws1.Cells(i, 3)
End With
ElseIf ws1.Cells(i, 4) & "組" = ws2.Cells(2, 5) Then
With ws2.Cells(Rows.Count, 5).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 1)
.NumberFormatLocal = "000"
.Offset(, 1) = ws1.Cells(i, 2)
.Offset(, 2) = ws1.Cells(i, 3)
End With
End If
End If
Next i
ws2.Range(Cells(4, 2), Cells(k, 6)).Sort key1:=ws2.Cells(4, 2), order1:=xlAscending
ws2.Range(Cells(4, 5), Cells(k, 7)).Sort key1:=ws2.Cells(4, 5), order1:=xlAscending
End Sub 'この行まで

参考になれば良いのですが・・・m(__)m

回答No.1

yy_kd

元データはVBAでソートする必要はないですね。
名簿シートのH2の数字は科目コードですね。あらかじめ元データを組み別にソートしてあるとすると
組が１の間、科目が〇の番号、名前、出身を名簿シートに順に書き出し、
組が２になったら書き出す列をE列にして１組と同様な処理をするだけではないですか？

お礼

yy_kd様

＞＞名簿シートのH2の数字は科目コードですね。

はい、その通りです。

＞＞組が１の間、科目が〇の番号、名前、出身を名簿シートに順に書き出し、組が２になったら書き出す列をE列にして１組と同様な処理をするだけではないですか？

はい、その通りです。

説明が下手でもうしわけございません。
そのやり方のご教授、どうぞよろしくお願いします。