TEST2

Sub Macro1()

‘ Macro1 Macro


Dim title, question As String
Dim rownum, colnum, lastnum, tablelines As Long
Dim org, trgt As Worksheet
Dim i, j, k As Integer
Dim ask As Range

Set org = Worksheets(“元データ”)
Set trgt = Worksheets(“test”)
k = 2 ‘ 貼り付け先用 (ラベル用に1行開けている)
‘header = 3 ‘ ヘッダー数指定
org.Select
lastnum = Cells(Rows.Count, 1).End(xlUp).Row ‘ 最終行数取得

For i = 1 To lastnum ‘ 行数分ループ
org.Select
If InStr(Cells(i, 1), “フィルター条件”) > 0 Then
question = Cells(i + 1, 1) ‘ 表頭取得
title = Cells(i + 2, 1) ‘ 表側取得
tablelines = Cells(i + 5, 1).End(xlDown).Row – i – 4 ‘ ターゲット層数取得。 5 は header 3 行と空白 2 行の和
rownum = Cells(i, 3).End(xlDown).Row ‘ 設問ヘッダー行の最初の行番号取得
colnum = Cells(rownum, Columns.Count).End(xlToLeft).Column – 2 ‘ 設問列数取得。

trgt.Select
‘ 最初に設問だけ貼り付け。設問の回答は後でループ処理
Range(Cells(k, 1), Cells(k – 1 + colnum * tablelines, 1)).Value = question ‘ 表頭貼り付け
Range(Cells(k, 2), Cells(k – 1 + colnum * tablelines, 2)).Value = title ‘ 表側貼り付け

‘ 設問の回答の処理
For j = i + 5 To i + 5 + tablelines – 1 ‘ ターゲット層数分ループ
org.Select
Range(Cells(rownum, 3), Cells(rownum + 1, colnum + 2)).Copy ‘ 設問ヘッダー取得

trgt.Select
Cells(k, 5).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True ‘ 設問貼り付け

‘ ターゲット層処理
org.Select
Range(Cells(j, 1), Cells(j, 2)).Copy
trgt.Select
Range(Cells(k, 3), Cells(k + colnum – 1, 4)).Select
ActiveSheet.Paste

‘ 回答選択

org.Select
Range(Cells(j, 3), Cells(j, colnum + 2)).Copy
‘ 回答貼り付け
trgt.Select
Cells(k, 7).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True ‘ 設問貼り付け
k = k + colnum
Next

End If
Next
End Sub

クロス集計をテーブルデータに_2

シェアする

  • このエントリーをはてなブックマークに追加

フォローする