【マクロ】記述を抜く

  アンケートなどの記述を抜き出す

抜き出した値は常の下に下に追加される

Set r2 = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

下に追加したくなければ上記コードを

Set r2 = ws2.Rnge("A2")

とすれば、常にA2セルから書き出す

Sub kijyutunuku()

Dim ws2 As Worksheet, rc1 As Range, rr1 As Range

Dim r2 As Range

Set ws2 = Worksheets("Sheet2") '書き出すシート

Set r2 = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '書き出すセルはA列の最終セル

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