エクセルのマクロを教えてください。

30問ほどのアンケートがあります。
シートに入力はしてあります。
A列にNo
B列に住まい
C列に年代
D列に問1回答
E列に問2記述
F列に問3記述
G列に問4回答
H列に問5記述
以下、続く


問2・3・5に記述があります。
各記述が入っている行を別シートに抜き出したいです。

問2の記述が入っている行のA・B・C・E列
問3の記述が入っている行のA・B・C・F列
問5の記述が入っている行のA・B・C・H列

上記を別シートに抜き出し
上から順番に並べたいです。
問2の記述を抜いたら
その下に問3
その下に問5
といった具合です。
このときにA列に問番号を入れたいです。

マクロを教えてください。

質問者からの補足コメント

• めぐみん様
  
  いろんなパターンでアンケートが行われています。
  入力用のシートが有り、全てをまとめて入力されています。
  そのなかでA列に日付が入ります。
  そのまとめたシートから記述のみを抜き出したいです。
  教えて頂いたコードは私の思い通りの結果です。
  とても助かっています。
  別パターンで月に何度か行われるアンケートがあります。
  それを年間通してまとめてみたいと思いました。
  1月1日分を入力したら記述を抜き出す、1月7日分を入力したら1日に抜き出した下に続けて抜き出す・・・・日付ごとに繰り返す。
  厚かましいですが、お願いいたします。

  
    補足日時：2021/02/02 07:58

No.10 ベストアンサー 回答者： めぐみん_ 回答日時： 2021/02/02 17:38

未検証ですけど。

Sub megu_2()
Dim ws2 As Worksheet, rc1 As Range, rr1 As Range
Dim r2 As Range

Set ws2 = Worksheets("Sheet2") '書き出すシート
Set r2 = ws2.Range("A2") '書き出す最初のセル

ws2.Range("A1:F1").Value = Array("日付","問", "Ｎｏ", "住まい", "年代", "記述")

With Worksheets("Sheet1") '元データのあるシート

For Each rc1 In .Range("E1", .Cells(1, Columns.Count).End(xlToLeft))

If rc1.Value Like "*記述" Then '項目名に【記述】がある時、

'仮に記述の列に何も記載がない（データが項目行のみ）と言う場合を除く
If WorksheetFunction.CountA(rc1.EntireColumn) > 1 Then

'ある列の記述がデータとして入っているセルだけを選び出す
Set rr1 = .Range(rc1.Offset(1), .Cells(Rows.Count, rc1.Column).End(xlUp)).SpecialCells(xlCellTypeConstants, 3)

Intersect(rr1.EntireRow, .Range("A:D")).Copy r2
rr1.Copy r2.Offset(, 5)

r2.Offset(, 1).Resize(rr1.Cells.Count).Value = Replace(rc1.Value, "記述", "")

Set r2 = r2.Offset(rr1.Cells.Count)

End If

End If

Next

End With

Set ws2 = Nothing
Set rr1 = Nothing

End Sub

この回答へのお礼

ありがとうございます！
本当に、ありがとうございます。
とても助かりました。
思う結果が出ました。
何度もおつ気合いいただき、感謝しています。
どうも、ありがとうございました。

お礼日時：2021/02/03 09:13

No.9 回答者： めぐみん_ 回答日時： 2021/02/02 08:51

それともマクロ実行日って訳でもないですよね？

アンケート入力をその日におこなうとは限らないと思いますし。

この回答へのお礼

アンケート実施日が日付となります。

お礼日時：2021/02/02 13:50

No.8 回答者： めぐみん_ 回答日時： 2021/02/02 08:48

その『日付』って元データのどこに入るのでしょう？

A列にNo
B列に住まい
C列に年代
D列に問1回答
E列に問2記述
F列に問3記述
G列に問4回答
H列に問5記述

が実際はズレて最初に日付・Ｎｏ・住まい～　となるのでしょうか？

この回答へのお礼

はい、その通りです。
入力用のシートが有り、A列に日付が入っています。

お礼日時：2021/02/02 13:50

No.7 回答者： めぐみん_ 回答日時： 2021/02/01 18:18

ところで日付が変わった際にデータはそのまま続けて書き込んで見づらくないですか？

マクロ実行毎に１行空白行を設けるって手もありますが？？？

この回答へのお礼

返信、ありがとうございます。
情報が足りませんでした。
お礼の欄に画像が貼れないので本質問に補足しておきました。
どうか、よろしくお願いします。

お礼日時：2021/02/02 08:00

No.6 回答者： めぐみん_ 回答日時： 2021/02/01 18:14

＞例えばアンケートを1月2日に行い、別の日の1月20日に別グループのアンケートを行いました。

この実施した日ってのはどこでわかるの？
例えばシート毎に（纏め済み？画像みたいな状態って事）違うってなら、

書き出すシート名と最初の書きだす位置を固定化しないってのと、元データのシートをアクティブシート（今現在見ているシート）って事にしてその都度マクロを実施しても良ければ可能とジジィは思えますよ。

No.5 回答者： めぐみん_ 回答日時： 2021/01/31 20:53

初級レベルなジジィには無駄に多くなってしまいました。

Sub megu()
Dim ws2 As Worksheet, rc1 As Range, rr1 As Range
Dim r As Range, r2 As Range

Set ws2 = Worksheets("Sheet2") '書き出すシート
Set r2 = ws2.Range("B2") '書き出す最初のセル

ws2.Range("A1:E1").Value = Array("問", "Ｎｏ", "住まい", "年代", "記述")

With Worksheets("Sheet1") '元データのあるシート

For Each rc1 In .Range("D1", .Cells(1, Columns.Count).End(xlToLeft))

If rc1.Value Like "*記述" Then '項目名に【記述】がある時、

'仮に記述の列に何も記載がない（データが項目行のみ）と言う場合を除く
If WorksheetFunction.CountA(rc1.EntireColumn) > 1 Then

'ある列の記述がデータとして入っているセルだけを選び出す
Set rr1 = .Range(rc1.Offset(1), .Cells(Rows.Count, rc1.Column).End(xlUp)).SpecialCells(xlCellTypeConstants, 3)

Intersect(rr1.EntireRow, .Range("A:C")).Copy r2
rr1.Copy r2.Offset(, 3)

r2.Offset(, -1).Resize(rr1.Cells.Count).Value = Replace(rc1.Value, "記述", "")

Set r2 = r2.Offset(rr1.Cells.Count)

End If

End If

Next

End With

Set ws2 = Nothing
Set rr1 = Nothing

End Sub

この回答へのお礼

どうも、ありがとうございます。
思った通りの完璧なコードを教えて頂いて言うのも申し訳ないんですが、
例えばアンケートを1月2日に行い、別の日の1月20日に別グループのアンケートを行いました。
最初に2日の記述を抜き出して、その下に20日の記述を抜き出すことは出来るでしょうか？
2行目から2日の記述が100行目まで抜き出したとして、101行目から20日の記述を追加する。また別のグループがあればその下に追加していく、といった具合です。
教えて頂いたコードを改造しようと試みましたが挫折しました。

お礼日時：2021/02/01 09:21

No.4 回答者： めぐみん_ 回答日時： 2021/01/29 20:59

あ～。

ちょっと引っ掛かる点があるのですが。

仮に『問２記述』の列をまず抜き出しますよね。
その時の『Ｎｏ』が何故飛び飛びのバラバラの順序になっているのでしょう？
単に仮データを作成した時の手違いってなら良いのですが、元のデータ順その物がキチンと並んでいない為ですかね？
それとも記述していない人がいる？にしても順序がバラバラになる訳はないですよね？虫食い状態になったとしても。

あくまでこの項目は気にすべきではなかったと言うので良いのでしょうか？

この回答へのお礼

飛び飛びになっているのは記述を書いていない人がいるためです。
図は参考として作ったため昇順ではなく並びが適当になっていました。

お礼日時：2021/02/01 08:51

No.3 回答者： ずんだしらたま 回答日時： 2021/01/29 18:30

手動操作と同じソート機能をマクロから使えるようですね。

https://excel-ubara.com/excelvba1/EXCELVBA388.html

元のシートを丸ごと別シートのb列以降にコピーして、sortメソッドで並び替え。
後からA列に連番を振れば出来そうな気がします。

No.2 回答者： fujillin 回答日時： 2021/01/29 11:59

こんにちは

手作業でやっても３項目ならすぐに終わる作業と思いますけれど、マクロ化して何回使う予定なのですか？

もしも、１回しか使う予定がないのなら、マクロを作成してテストしている時間の方が遥かに時間がかかります。
（その間にとっくに終わっている）

この回答へのお礼

項目は沢山あります。
記述欄も沢山あります。
今回だけでなくずっと使用したいです。

お礼日時：2021/02/01 08:52

No.1 回答者： めぐみん_ 回答日時： 2021/01/29 10:26

色分けは含まれるのですか？

含まれる場合、その指定する色は？

『記述』している列を見分ける方法とは？
１行目の項目に『記述』と言う語句が記載されている（含まれている）のですか？

この回答へのお礼

1行目の項目は固定で、記述の列は記述と項目名にしています。
色は必要ありません。
質問用に視覚的に分かりやすく付けただけです。

お礼日時：2021/01/29 15:28