表からの動的作成

質問

添付した画像の図(1)の表から、図(2)のような問題回答画面を別シートに動的につくりたいと考えています。
問題の回答方法は、設問に対し選択肢から複数選べるというものです。

図(1)の表を配列に読み込んで、問題解答画面を作る際にひとつひとつ配列から要素を引っこ抜いて反映していく、選択肢の数に応じてチェックボックスも動的に配置していく。という方法を考えていたのですが、いざコードを書こうとするとどう書いていいものか思い浮かばず頭を抱えてしまいました。

実装のためのコードのヒントや、実装にあたってアプローチなど、お知恵を貸して頂けないでしょうか。

回答No.5

imogasi

#3です。＃３でチェックのしるしはＡ列において、チェックボックスをＶＢＡで配置し使いました。
しかし（フォームに乗せるチェックボックスではなく）シートに配置するチェックボックス（ＭＳエクセルでは正統的ではないと考えられているように個人的に推測する）では、グループ化（同じ質問行のグループでは１つしか入力できない）ようにしたくて、いろいろやってみました（ＧｒｏｕｐＮａｍｅ設定など）が、できない（私の知識不足かもしれないが）ので、下記をやってみました。
本件はＡ列の各行には，回答者がチェックを入れる、コントロールのチェックボックスは設定しない。空白のままにする。
Ａ列の回答したい選択肢の行を選択してクリックすると、下記ではその行のＡ列に「Ｖ」の字を入れる。
すでに同じ問題で他行のグループの行に、Ｖが入っておれば、クリックしたセルにＶ字を移す、という内容です。
ーー
Ｓｈｅｅｔ１のＳｅｌｅｃｔｉｏｎのＣｈａｎｇｅイベントで
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub 'Ａ列だけの変化に注目
r = Target.Row ' 選択行の行番号を一時保存。既存分抹消後、最後の辺で利用する。
v = Worksheets("Sheet1").Range("b" & r) 'そのＢ列の値を取る（問題番号を捉える）
rf = ActiveSheet.Range("B1:B1000").Find(v).Row 'その問題番号の最初出現行を把握
'--B列の同じ問題番号の（設問選択肢行）の行のＡ列をクリア
Do While Range("B" & rf) = v 'Ｂ列が同じ問題番号行の間は繰り返し
Range("A" & rf) = "" 'Ａ列既存の値はクリア
rf = rf + 1 '次行について繰り返し準備
Loop
'--
Range("a" & r) = "V" '当初選択した１行だけのＡ列だけにチェックサインを代入
’すでにＶを入れている場合は、入れる値（Ｖ）の行（選択肢）を移動した、に該当する処理
’Ｖはチェックに似せて使ってますが、丁寧には英字でなく適当な記号を使うほうがベター
End Sub
ーー
参考までに
＃３回答でチェックボックスの「チェクボックス」の文言を（邪魔なので）消すのは
Set ckb = ws2.CheckBoxes.Add(cl.Left + 1, cl.Top + 1, 20, 20)
ckb.Caption = ""　’＜＝＝この行追加
でできます。

回答No.4

real beatin（@realbeatin）

> ＃１補足

、、、って、
新しい情報は「ご察しの通りエクセル（VBA）」だけなのに、
「おかわり」ですか？
なんかよく解りませんけれど、ひたすら画像を読む眼力と勘を頼りに
４つの追加注文について、一纏めにして、今一度お応えします。
でも、
うまくいったとしてもせいぜいまた「ほぼ望んでいたもの」程度
にしかならないでしょうから、後はそちらでの応用に任せるとして、
私はこれで退席します。課題に必要なパーツの提示は済んだと思います。
偉く親切な御仁が現れて救ってくれるならそれで善し、
叶わずとも更に求めるなら、
質問する場所や質問スタンスを変えた方がいいことあるかも、です。

因みに、
「.WrapText = True」を設定したとしても、、
[セルの結合]]を設定したセル範囲では、
●行高の自動調整が機能しない
のがExcelの仕様です。
行高を再設定するような手だてがない訳ではありませんが、
この質問の本題からは離れた課題ですので、必要なら別件でお訊ねください。
詳らかな説明があれば、また私もお応えするかも知れません。

' ' ///

Sub w8978838おかわり()
Dim vTemp
Dim wksS As Worksheet
Dim wksP As Worksheet
Dim wksL As Worksheet
Dim a As Range
Dim sLink As String
Dim nTemp As Long
Dim nBtmRow As Long
Dim nCurNum As Long
Dim cnPrtRow As Long
Dim n1stRow As Long
Dim n1stCol As Long
Dim iRow As Long
Dim iCol As Long

　　Application.ScreenUpdating = False

Call RemoveAllOnSheet　'　?

　　Set wksS = Sheets("Sheet1")　'　◆
　　nBtmRow = wksS.Cells(Rows.Count, "A").End(xlUp).Row

　　Set wksP = Sheets("Sheet2")　'　◆
　　n1stRow = 2　'　◆
　　n1stCol = 2　'　◆
　　wksP.Columns(n1stCol).ColumnWidth = 4 '　◆
　　wksP.Columns(n1stCol + 1).ColumnWidth = 30 '　◆

　　Set wksL = Sheets("Sheet3")　'　　'　リンク先◆　'　★ > ３．
　　sLink = "'" & wksL.Name & "'!A"　'　sLink = "'Sheet3'!A"　'　A ? ◆　'　★ > ３．

　　nCurNum = 0
　　cnPrtRow = n1stRow - 1
　　For iRow = 2 To nBtmRow
　　　　nTemp = wksS.Cells(iRow, 1)
　　　　If nTemp > nCurNum Then
　　　　　　nCurNum = nTemp
　　　　　　cnPrtRow = cnPrtRow + 1
　　　　　　wksP.Cells(cnPrtRow, n1stCol) = "問" & nCurNum & "." & wksS.Cells(iRow, 2)　'　★ > １．結合＝セルの結合？
　　　　　　With wksP.Cells(cnPrtRow, n1stCol)
　　　　　　　　.Interior.Color = &HB4D5FC
　　　　　　　　.Font.Bold = True
　　　　　　　　.Resize(, 2).Merge　'　★ > １．結合＝セルの結合？
　　　　　　End With
　　　　End If

　　　　vTemp = wksS.Cells(iRow, 3)
　　　　If vTemp <> "" Then
　　　　　　cnPrtRow = cnPrtRow + 1
　　　　　　wksP.Cells(cnPrtRow, n1stCol + 1) = vTemp
　　　　　　With wksP.Cells(cnPrtRow, n1stCol)
　　　　　　　　With wksP.OLEObjects.Add( _
　　　　　　　　　　　　　　ClassType:="Forms.CheckBox.1", Link:=False, _
　　　　　　　　　　　　　　Left:=.Left + 1, Top:=.Top + 1, Width:=.Width - 2, Height:=.Height - 2)
　　　　　　　　　　.Object.Caption = ""
　　　　　　　　　　.LinkedCell = sLink & iRow　'　★ > ３．
　　　　　　　　End With
　　　　　　End With
　　　　End If
　　Next iRow

　　With wksP.Cells(n1stRow, n1stCol).Resize(cnPrtRow - n1stRow + 1, 2)
　　　　.Borders.LineStyle = xlContinuous
　　　　.WrapText = True　'　★ > ２．（！結合セルには通用しない∵Excelの仕様）
　　End With
　　For Each a In wksP.Cells(n1stRow, n1stCol).Resize(cnPrtRow - n1stRow + 1).SpecialCells(xlCellTypeBlanks).Areas
　　　　a.Resize(a.Rows.Count + 1, 2).Offset(-1).BorderAround Weight:=xlMedium
　　Next

　　wksL.Cells(2, "A").Resize(nBtmRow - 1).Value = 0 '　★ > ３．

　　Application.ScreenUpdating = True
End Sub

回答No.3

imogasi

#2です。
コード１案
Sub test01()
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
' 初期設定
lr1 = ws1.Range("A10000").End(xlUp).Row
j = 2
maeq = ws1.Range("A2")
'--アウトプット初期設定
ws2.Range("A" & j) = "問" & ws1.Range("A" & 2)
ws2.Range("B" & j) = ws1.Range("B" & 2)
j = j + 1
'--繰り返し
For i = 2 To lr1
'－－
If maeq = ws1.Range("A" & i) Then
'　問が同じ
ws2.Range("B" & j) = ws1.Range("C" & i) '設問をセット
Else
' 問が変わった
ws2.Range("A" & j) = "問" & ws1.Range("A" & i)
ws2.Range("B" & j) = ws1.Range("B" & i)
j = j + 1 '１行下行のＢ列に
ws2.Range("B" & j) = ws1.Range("C" & i)
End If
'－－
j = j + 1 '次は1行下に
maeq = ws1.Range("A" & i) '設問番号をセット
Next i
End Sub
ーー
チェックボックスは
Sub test02()
Set ws2 = Worksheets("Sheet2")
lr2 = ws2.Range("B10000").End(xlUp).Row
MsgBox lr2
For i = 3 To lr2
Set cl = ws2.Range("A" & i)
If cl = "" Then
ws2.CheckBoxes.Add cl.Left + 1, cl.Top + 1, 20, 20
End If
Next i
End Sub
ーー
チックボックスだけの消去は(テスト用に使う）
Sub test03()
Worksheets("Sheet2").DrawingObjects.Delete
End Sub
ーー
チェックボックスのタイトル消去とチェックボックスのグループ化の問題があるが今回略。

回答No.2

imogasi

私も＃１さんと同じく、画像だけ張り付けて質問やコードだけ張り付けて質問し
、したい処理の意図など説明しない質問が多いということを常々感じて、
回答に書いたり感じています。
使用言語やバージョンなども書かない質問が多い。
読者・回答者は「他人」「他コンピュター」ということを考えてないように思う。
図はＯＫＷＡＶＥの質問では小さかったりぼやけている場合が多い。
ーー
本質問では幸い図１と図２で、本筋の並び順は同じで、問題番号と、設問が各問題の
最初行に出ているだけでしょう。
配列にいったん保管する必要はないタイプでしょう。
昔はコンピュターの使用メモリが少なく、ため込み（配列もその発想）はしないという前提で
並べ替えなどを工夫して、プログラムを組まされました。
ーー
やりたいことを、処理の流れに従って文章にする訓練をすれば、本問題など
簡単なものだと思う。
たとえば
（１）図１で設問行を見つける。＜－－下記（６）から
（２）　　図２で「問Ｘ」を作る。
（３）　「設問」を見つけて、図２にセット
（４）図２で行を変える。図２で選択肢行の列を作る
（５）同じ問題の間は、図２で選択肢のみＢ列に持ってくる。処理行を下に移す。
　　　その後（５）を繰り返す。変化は下記（７）が起こったとき。　
問題は
（６）設問行を見つける方法
（７）新たな設問行になったことを検出。
をどうするか。
（Ａ）図１のＡ列の変化を捉えるか、（Ｂ）Ｂ列の空白以外のセルの出現
でできるでしょう。
こういう場合は、わからないのはＸで、と質問が絞られて、回答者にもよくわかる。
　または処理ロジック（処理の考え方。発想）についてよいやり方の提案も出て
質問者に勉強になるでしょう。
ーー
以上で、配列に収める必要なぞないと思う。
昔は、前行（前レコード）との変化をＷＡＴＣＨすることを、「コントロール（ＶＢＡの
フォームなどの「部品」と違う用語）を捉える」と言っていましたが、
ＶＢＡでも有効な考え方と思う。
具体的コード回答は間に合えば後刻。
ーー
「動的作成」など、大げさで、本質問と違う意味に使う場合が多いと思う。

回答No.1

real beatin（@realbeatin）

こんにちは。

最初にエクスキューズしておきますが、
●画像を見ただけで'やりたい事'を察するには無理が伴うこと
●[オフィス系ソフト]カテゴリへ投稿された質問なのに
　アプリケーションや言語を示さずにコードについて語れ、
　というのは無理だということ
読む側にとっては、非常に不親切な質問になっていますから、
こちらが提示できるものも、その程度にしか書けませんので、
あまり期待しないでくださいね。

ご質問の投稿先が、もしも、[Excel（エクセル）]カテゴリ、だったなら、
という前提で、Excel ＶＢＡ についてお応えします。
もし違っていた場合は、この質問については一旦、
「未解決のまま」「締切」にして、新たに質問を建てるようにしないと、
回答は付かないと思います。

> 実装のためのコードのヒントや、実装にあたってアプローチなど、お知恵を貸して頂けないでしょうか。
ということなのですが、前提が不確かなものについて、
十分な説明文を書く、という気には、どうしてもなれなかったので、
私にとっては、より簡易な方法として、具体的に動くコード、を
参考になれば、という気持ちで示します。

> 図(1)の表を配列に読み込んで、問題解答画面を作る際にひとつひとつ配列から要素を引っこ抜いて反映していく、
> 選択肢の数に応じてチェックボックスも動的に配置していく。
問題の数が万単位ということでもなければ、
特に配列を持ち出す理由（メリット）もない訳ですし、
シート上に配置するチェックボックスの総数についても、
Excelの仕様上は明確な制限はないものの万単位では無理があるでしょう。
そう考えると、敢えて配列を使わなくても、普通にFor分でCellsをループした方が、
簡単に、ほぼ同程度の処理速度のものが書けると思いますから、
本来は、そういう誘導をするべきなのかとも考えました。
しかし要求を覆す根拠が、こちらが想像した要求仕様というのでは、
お話になりませんよね。
なので、お求めのまま、「配列に読み込んで...」処理するものを提示します。

チェックボックスについては、
　フォームコントロール
　ActiveXコントロール
の内、後者でお応えしています。

元の表のセル範囲としての捉え方については、
何を基準にするべきか判断できなかったので、.CurrentRegionを使っています。
元の表全体を捉える方法についてはそちらで適当な方法をえらんでください。
無論、他の部分についても、「応用して貰う為の記述」ですので、、、。

以下、
私が提示した物に関しては、
もしも解らない点があれば、補足質問あればお応えします。

' ' ///

Sub w8978838()
Dim mtxS()
Dim mtxP()
Dim vTemp
Dim tnRow As Long
Dim nCurNum As Long
Dim c As Range
Dim a As Range
Dim iRow As Long
Dim iCol As Long
Dim cnPrtRow As Long

　　mtxS = Sheets("Sheet1").Cells(1, 1).CurrentRegion.Value

　　tnRow = UBound(mtxS)
　　ReDim mtxP(1 To tnRow * 2, 1 To 2)

　　For iRow = 2 To tnRow
　　　　If mtxS(iRow, 1) <> nCurNum Then
　　　　　　nCurNum = mtxS(iRow, 1)
　　　　　　cnPrtRow = cnPrtRow + 1
　　　　　　mtxP(cnPrtRow, 1) = "問" & StrConv(nCurNum, vbWide)
　　　　　　mtxP(cnPrtRow, 2) = mtxS(iRow, 2)
　　　　End If

　　　　vTemp = mtxS(iRow, 3)
　　　　If vTemp <> "" Then
　　　　　　cnPrtRow = cnPrtRow + 1
　　　　　　mtxP(cnPrtRow, 2) = vTemp
　　　　End If
　　Next iRow

　　Application.ScreenUpdating = False
　　With Sheets("Sheet2").Cells(2, 2)
　　　　With .Resize(cnPrtRow, 2)
　　　　　　.Columns(1).ColumnWidth = 4
　　　　　　.Columns(2).ColumnWidth = 60
　　　　　　.Value = mtxP
　　　　　　.Borders.LineStyle = xlContinuous
　　　　End With

　　　　For Each c In .Resize(cnPrtRow).SpecialCells(xlCellTypeConstants)
　　　　　　With c.Resize(, 2)
　　　　　　　　.Interior.Color = &HB4D5FC
　　　　　　　　.Font.Bold = True
　　　　　　End With
　　　　Next

　　　　For Each a In .Resize(cnPrtRow).SpecialCells(xlCellTypeBlanks).Areas
　　　　　　a.Resize(a.Rows.Count + 1, 2).Offset(-1).BorderAround Weight:=xlMedium
　　　　　　a.Font.Color = vbWhite
　　　　　　a.Value = 0

　　　　　　For Each c In a.Cells
　　　　　　　　With c
　　　　　　　　　　With .Worksheet.OLEObjects.Add( _
　　　　　　　　　　　　ClassType:="Forms.CheckBox.1", Link:=False, _
　　　　　　　　　　　　Left:=.Left + 1, Top:=.Top + 1, Width:=.Width - 2, Height:=.Height - 2)
　　　　　　　　　　　　With .Object
　　　　　　　　　　　　　　.BackColor = vbWhite
　　　　　　　　　　　　　　.Caption = ""
　　　　　　　　　　　　End With
　　　　　　　　　　　　.LinkedCell = c.Address(0, 0)
　　　　　　　　　　End With
　　　　　　　　End With
　　　　　　Next
　　　　Next

　　End With
　　Application.ScreenUpdating = True
End Sub

Sub RemoveAllOnSheet()
　　With Sheets("Sheet2")
　　　　.Select
　　　　.UsedRange.EntireColumn.Delete
　　　　.OLEObjects.Select
　　　　Selection.Delete
　　End With
End Sub

補足

realbeatin様

情報の提示が不十分であったり、意図していることが不明確だったりと、
回答がしにくいなか丁寧なご回答とご指摘ありがとうございます。

急ぎで完成させたいこともあり、気持ちが焦って
受け手のことを考えない質問内容となってしまい申し訳ありませんでした。
今後十分に注意いたします。ご指摘ありがとうございました。

ご察しの通りエクセル（VBA）での回答を希望しておりました。
realbeatin様にご提示頂いたコードでほぼ望んでいたものができあがり感動しております。

＞敢えて配列を使わなくても、普通にFor分でCellsをループした方が、
＞簡単に、ほぼ同程度の処理速度のものが書ける
こういった考え方を提示して頂けるのもとても参考になります。
こちらのFor分でCellsをループする方法もぜひご教授頂けませんでしょうか。

話が戻りまして、いくつか追加でお伺いしたいことがあるのですが…

１．
提示頂いたコード後半、配列に読み込んだ諸々を
.Value = mtxP　にて、シートに書き出しますが
設問1.|AAA　とセル毎に設問1.、AAAと書き出されたものを
設問1.AAA　のように設問番号と設問を結合するには、どうしたらよいのでしょうか。

２．
また、設問と選択肢の文章が長くなった場合にセル内で折り返すようにしたいのですが、
設問と選択肢のセルのみ.WrapText = Trueとするにはどうしたらよいのでしょうか。

３・
動的に配置したチェックボックスのリンクセルを別シートに指定する場合はどうしたらよいのでしょうか。
別シートにのCells(i,1)に羅列したいと考えております。

度々申し訳ありませんが、ご教授いただけると幸いです。