TEST3

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 Long
Dim ask As Range

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

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

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

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

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

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

‘ 回答選択

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

End If
Next
End Sub

シェアする

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

フォローする