エクセルVBA　ユーザーフォームでアンケートを取る。結果をSheetに転記する。

ユーザーフォームでアンケート入力のフォームを作る。

エクセルでアンケートを入力したことがあるという人は多いのではないでしょうか。
この記事では、エクセルVBAのユーザーフォームを使ってアンケートを取るマクロを開発します。
架空のサービス満足度調査を題材として、ユーザーフォームを作成しました。

目次
　１　閲覧対象者
　２　得られる効果
　３　設計
　４　アンケートフォームの作り方
　５　Sheetに転記するためのコードを作成する
　６　入力エラー判定処理の追加
　７　作ってみて感想
　８　全コード

１　閲覧対象者

エクセルVBAのユーザーフォームでアンケートマクロを作成したい初心者の人。
アンケート作成例を調べたいという人向けです。

２　得られる効果

以下の入力フォームから入力後に、
f:id:bimori466:20200417211943p:plain

自ブックのSheetに転記します。
f:id:bimori466:20200417212203p:plain

３　設計

ユーザーフォームから、自ブックのSheetに結果を記入する。
質問ごとにFrameを作る。

４　アンケートフォームの作り方

Q1　年齢

ツールボックスでフレームを選択し、フォームにフレームを作ります。
f:id:bimori466:20200417214018p:plain

フレームの中に年齢のオプションボタンを作ります。
オプションボタンは１つしか選択できません。１０代を選んだあと２０代を選んだら、１０代のチェックは消えます。どれか一つだけを選んでもらうときにオプションボタンを使います。
f:id:bimori466:20200417214438p:plain

Q２　職業

ほぼ年齢と同じです。
工夫してることが１点。その他はクリックされたときに表示されるようにしています。
f:id:bimori466:20200417222736p:plain

厳密にいうと、クリックではなく変更（Change）されたときです。
以下、表示をコントロールするフォーム内イベントモジュール。

Private Sub opt_職業_その他_Change()

If opt_職業_その他.Value = True Then
    txt_職業_その他.Visible = True
Else
    txt_職業_その他.Visible = False
End If

End Sub

Q３　サービスをどこで知ったか

職業と同じです。

Q4　サービスの利用頻度

年齢と同じです。

Q5　サービスの使用理由

ここのポイントは「複数回答」です。
チェックボックスを使います。
オプションボタンとは違い、複数選択が可能です。
f:id:bimori466:20200417223736p:plain

Q６　その他記入

自由記入型式です。テキストボックスを使います。
f:id:bimori466:20200417224212p:plain

回答コマンド

Q１～Q6までの情報をSheetに転記するためのコマンドボタンです。
f:id:bimori466:20200417224519p:plain

回答初期化コマンド

ユーザーフォームを最初の状態に戻します。
f:id:bimori466:20200418064412p:plain

ユーザーフォームのオブジェクトに名前を付ける。

以上でユーザーフォームのインターフェイスが完成しました。

f:id:bimori466:20200417211943p:plain

見た目は完成したのですが、コードを書くときに「どこのなにを操作しているのか」が分からなくなります。
そのため、Frame、オプションボタンなどにそれぞれ名前を付けます。

frame

対象のFrameを選択し、オブジェクト名を変更します。
f:id:bimori466:20200418071639p:plain

名前の付け方　　　　　　　　　　　　　例
Frame　　　　　→　Frame_＊　　　　　Frame_age
OptionButton　　→　opt_＊　　　　　　opt_10
CheckBox　　　→　che_＊　　　　　　che_他社
TextBox　　　　→　txt_＊　　　　　　 txt_職業_その他
commandButton →　cmd_＊　　　　　 cmd_回答

「入力のがわ」ができたので、次にSheetに転記するためのコードを作成します。

５　Sheetに転記するためのコードを作成する

ユーザーフォームで入力した値をSheetに転記するためのコードを書いていきます。
処理の考え方は「Frameごとに処理する」です。
Q1～Q６ごとにやっていきましょう。

Q1　年齢

オプションボタンはいずれか「１つだけ」しか選択できません。
つまり、Frame内のコントロールを検索してチェックがついているもの（value＝true）を調べて、それをSheetに代入します。
調べるための構文は「For　each　in」です。年齢のFrameをループ処理します。
コマンドボタン回答をクリックしたときに、転記処理を実行します。

以下、年齢転記処理イベントプロシージャコード

Private Sub cmd_回答_Click()

Dim sh As Worksheet
Set sh = Worksheets("回答集計")

'最終行の取得
Lline = sh.Cells(Rows.Count, 1).End(xlUp).Row


'年齢入力
For Each age In Frame_age.Controls
    If age.Value = True Then
        If age.Name Like "*10" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
            
        ElseIf age.Name Like "*20" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
        
        ElseIf age.Name Like "*30" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
        
        ElseIf age.Name Like "*40" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
        
        ElseIf age.Name Like "*50" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
        
        ElseIf age.Name Like "*60" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
            
        End If
    End If
Next age

転記用のWorksheets("回答集計")の最終行を取得して、その行＋１行目に結果を書き込みます。
If条件で使っているage.Nameは、名前を設定した部分を判定しています。
例えば、１０代のオプションボタンの名前は「opt_10」となっています。
なので、１０代にがクリックされていて、オブジェクト名が「＊１０」であれば、
Sheetに「opt_10」のCaptionを転記します。
Captionとは、ユーザーフォーム上で見えている名前です。

f:id:bimori466:20200418093416p:plain

結果はこうなります。年代欄に10代が転記されました。
f:id:bimori466:20200418093616p:plain

Q2　職業

年齢とほぼ同じですが、その他の部分だけ違います。
Captionではなく、テキストボックスの値を代入します。

以下、処理コード

'職業

For Each job In Frame_job.Controls
    If job.Value = True Then
        If job.Name Like "*主婦" Then
            sh.Cells(Lline, 2) = job.Caption
        
        　　～略～

        ElseIf job.Name Like "*その他" Then
            sh.Cells(Lline, 2) = txt_職業_その他.Value
        End If
    End If
        
Next job

Q３　サービスをどこで知ったか

職業と同じ。
（全コードは最後に貼っときます。）

Q４　サービスの利用頻度

年齢と同じです。

Q５　サービスの使用理由

チェックボックスのループです。変数「理由」を作って、ここに回答を「,（カンマ）」で区切って転記します。
後で集計する際には、COUNTIFでワイルドカードを使った検索で集計できるので、この方法にしました。
（例：= COUNTIF（$ C $ 7：$ C $ 1048576、 "*"＆C3＆ "*"））

以下、処理コード

'サービス使用理由
For Each 使用理由 In Frame_理由.Controls
    If 使用理由.Value = True Then
        If 使用理由.Name Like "*他社" Then
            If 理由 = "" Then
                理由 = 使用理由.Caption
            Else
                理由 = 理由 & "," & 使用理由.Caption
            End If
        
        ElseIf 使用理由.Name Like "*評判" Then
            If 理由 = "" Then
                理由 = 使用理由.Caption
            Else
                理由 = 理由 & "," & 使用理由.Caption
            End If
        
        ElseIf 使用理由.Name Like "*勝手" Then
            If 理由 = "" Then
                理由 = 使用理由.Caption
            Else
                理由 = 理由 & "," & 使用理由.Caption
            End If
        
        ElseIf 使用理由.Name Like "*信頼" Then
            If 理由 = "" Then
                理由 = 使用理由.Caption
            Else
                理由 = 理由 & "," & 使用理由.Caption
            End If
        End If
    End If
Next 使用理由

'Sheetに転記
sh.Cells(Lline, 5) = 理由

Q６　その他記入

テキストボックスの値をそのまま代入します。

以下、処理コード

'その他
sh.Cells(Lline, 6) = txt_自由記入.Value

６　入力エラー判定処理の追加

転記コードが書けました。しかし、人が操作するならヒューマンエラーは避けられません。
入力エラーのコードを転記処理の前部分に作っていきましょう。

Q１　年齢

エラーとしては「選択されていない」ことです。
ではどう判断するか。答えは、フレームをループしてすべてvalue＝Falseのときです。
では、コードを記述しましょう。

以下、処理コード

Dim End_Flg As Boolean

Sub 回答入力チェック()

'年齢チェック------------------------------------------------------------------
Dim age_count As Byte: age_count = 0


For Each age In Frame_age.Controls
    If age.Value = False Then
        age_count = age_count + 1
    End If
Next age
    

If age_count = Frame_age.Controls.Count Then
    MsgBox "年齢が選択されていません。"
    End_Flg = True
    Exit Sub
End If
'______________________________________________________________________________

まず、変数End_Flgを先頭に記述します。
これは「回答チェック」という処理を「Private Sub cmd_回答_Click()」から呼び出しており、「回答チェック」内で変数宣言するとエラーチェック終了後、「Private Sub cmd_回答_Click()」の処理に戻った時に変数が破棄されるからです。変数のスコープ（範囲）の問題です。
エラー処理の話に戻って、オプションボタンのfalseの数を変数age_count で数えます。その数が、Frameのコントロールの数と一致していれば、未回答ということになります。「変数End_Flg＝true」とします。
「Private Sub cmd_回答_Click()」の処理に戻って、「変数End_Flg＝true」なら処理を終了します（Exit Sub）。

以下、cmd_回答_Click()のエラー判定処理コード部

Private Sub cmd_回答_Click()

Call 回答入力チェック


'エラー判定--------------------------------------------------------------------
If End_Flg = True Then
    'フラグ初期化して終了
    End_Flg = False
    Exit Sub
End If
'______________________________________________________________________________

Q２　職業

年齢と同様です。
ただし、テキストボックスが１つあるのでコントロールカウントを１つ引きます（Frame_job.Controls.Count - 1）。

Q3　サービスをどこで知ったか

職業と同じです。

Q４　サービスの利用頻度

年齢と同じです。

Q５　サービスの使用理由

年齢と同じ。

以上です。

７　作ってみて感想

社内の一部署で使用する、もしくはメールで展開する使い方としては悪くないのかと思います。
しかし、ひとりしか入力できないのが難点です。この点は、ＳＱＬ文で別のBookに転記する方法に変えればOKです。
また、Q３でエラーが出た場合、Q１、２は転記されてしまうのでこの点も改善点です。

８　全コード

標準モジュール（呼び出すだけ）

Sub UF_Show()

UserForm1.Show

End Sub

フォームモジュール

Dim End_Flg As Boolean

Sub 回答入力チェック()

'年齢チェック------------------------------------------------------------------
Dim age_count As Byte: age_count = 0


For Each age In Frame_age.Controls
    If age.Value = False Then
        age_count = age_count + 1
    End If
Next age
    

If age_count = Frame_age.Controls.Count Then
    MsgBox "年齢が選択されていません。"
    End_Flg = True
    Exit Sub
End If
'______________________________________________________________________________


'職業チェック------------------------------------------------------------------
For Each job In Frame_job.Controls
    If job.Value = False Then
        job_count = job_count + 1
    End If
Next job
    

If job_count = Frame_job.Controls.Count - 1 Then
    MsgBox "職業が選択されていません。"
    End_Flg = True
    Exit Sub
End If

If opt_職業_その他.Value = True Then
    If txt_職業_その他 = "" Then
        MsgBox "「職業」その他欄が入力されていません。"
        End_Flg = True
        Exit Sub
    End If
End If

'______________________________________________________________________________



'サービス認知チェック----------------------------------------------------------
For Each サービス認知 In Frame_サービス認知.Controls
    If サービス認知.Value = False Then
        サービス認知_count = サービス認知_count + 1
    End If
Next サービス認知
    

If サービス認知_count = Frame_サービス認知.Controls.Count - 1 Then
    MsgBox "サービス認知が選択されていません。"
    End_Flg = True
    Exit Sub
End If

If opt_サービス認知_その他.Value = True Then
    If txt_サービス認知_その他 = "" Then
        MsgBox "「サービス認知」その他欄が入力されていません。"
        End_Flg = True
        Exit Sub
    End If
End If
'______________________________________________________________________________


'サービス利用頻度チェック----------------------------------------------------------
For Each サービス利用頻度 In Frame_利用頻度.Controls
    If サービス利用頻度.Value = False Then
        サービス利用頻度_count = サービス利用頻度_count + 1
    End If
Next サービス利用頻度
    

If サービス利用頻度_count = Frame_利用頻度.Controls.Count Then
    MsgBox "サービス利用頻度が選択されていません。"
    End_Flg = True
    Exit Sub
End If
'______________________________________________________________________________


'サービス理由チェック----------------------------------------------------------
For Each サービス理由 In Frame_理由.Controls
    If サービス理由.Value = False Then
        サービス理由_count = サービス理由_count + 1
    End If
Next サービス理由
    

If サービス理由_count = Frame_理由.Controls.Count Then
    MsgBox "サービス使用理由が選択されていません。"
    End_Flg = True
    Exit Sub
End If
'______________________________________________________________________________


End Sub

Private Sub cmd_回答_Click()

Call 回答入力チェック


'エラー判定--------------------------------------------------------------------
If End_Flg = True Then
    'フラグ初期化して終了
    End_Flg = False
    Exit Sub
End If
'______________________________________________________________________________


Dim sh As Worksheet
Set sh = Worksheets("回答集計")

'最終行の取得
Lline = sh.Cells(Rows.Count, 1).End(xlUp).Row


'年齢入力
For Each age In Frame_age.Controls
    If age.Value = True Then
        If age.Name Like "*10" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
            
        ElseIf age.Name Like "*20" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
        
        ElseIf age.Name Like "*30" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
        
        ElseIf age.Name Like "*40" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
        
        ElseIf age.Name Like "*50" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
        
        ElseIf age.Name Like "*60" Then
            Lline = Lline + 1
            sh.Cells(Lline, 1) = age.Caption
            
        End If
    End If
Next age


'職業

For Each job In Frame_job.Controls
    If job.Value = True Then
        If job.Name Like "*主婦" Then
            sh.Cells(Lline, 2) = job.Caption
        
        ElseIf job.Name Like "*会社員" Then
            sh.Cells(Lline, 2) = job.Caption
        
        ElseIf job.Name Like "*公務員" Then
            sh.Cells(Lline, 2) = job.Caption
        
        ElseIf job.Name Like "*自営業" Then
            sh.Cells(Lline, 2) = job.Caption
        
        ElseIf job.Name Like "*アルバイト" Then
            sh.Cells(Lline, 2) = job.Caption
        
        ElseIf job.Name Like "*学生" Then
            sh.Cells(Lline, 2) = job.Caption
        
        ElseIf job.Name Like "*その他" Then
            sh.Cells(Lline, 2) = txt_職業_その他.Value
        End If
    End If
        
Next job


'サービス認知
For Each サービス認知 In Frame_サービス認知.Controls
    If サービス認知.Value = True Then
        If サービス認知.Name Like "*テレビ" Then
            sh.Cells(Lline, 3) = サービス認知.Caption
        
        ElseIf サービス認知.Name Like "*ラジオ" Then
            sh.Cells(Lline, 3) = サービス認知.Caption
        
        ElseIf サービス認知.Name Like "*新聞・チラシ" Then
            sh.Cells(Lline, 3) = サービス認知.Caption
        
        ElseIf サービス認知.Name Like "*SNS" Then
            sh.Cells(Lline, 3) = サービス認知.Caption
        
        ElseIf サービス認知.Name Like "*ネット" Then
            sh.Cells(Lline, 3) = サービス認知.Caption
        
        ElseIf サービス認知.Name Like "*口コミ" Then
            sh.Cells(Lline, 3) = サービス認知.Caption
        
        ElseIf サービス認知.Name Like "*その他" Then
            sh.Cells(Lline, 3) = txt_サービス認知_その他.Value
            
        End If
    End If
Next サービス認知


'サービス利用頻度
For Each 利用頻度 In Frame_利用頻度.Controls
    If 利用頻度.Value = True Then
        If 利用頻度.Name Like "*毎日" Then
            sh.Cells(Lline, 4) = 利用頻度.Caption
        
        ElseIf 利用頻度.Name Like "*月1" Then
            sh.Cells(Lline, 4) = 利用頻度.Caption
        
        ElseIf 利用頻度.Name Like "*週1" Then
            sh.Cells(Lline, 4) = 利用頻度.Caption
        
        End If
    End If
Next 利用頻度


'サービス使用理由
For Each 使用理由 In Frame_理由.Controls
    If 使用理由.Value = True Then
        If 使用理由.Name Like "*他社" Then
            If 理由 = "" Then
                理由 = 使用理由.Caption
            Else
                理由 = 理由 & "," & 使用理由.Caption
            End If
        
        ElseIf 使用理由.Name Like "*評判" Then
            If 理由 = "" Then
                理由 = 使用理由.Caption
            Else
                理由 = 理由 & "," & 使用理由.Caption
            End If
        
        ElseIf 使用理由.Name Like "*勝手" Then
            If 理由 = "" Then
                理由 = 使用理由.Caption
            Else
                理由 = 理由 & "," & 使用理由.Caption
            End If
        
        ElseIf 使用理由.Name Like "*信頼" Then
            If 理由 = "" Then
                理由 = 使用理由.Caption
            Else
                理由 = 理由 & "," & 使用理由.Caption
            End If
        End If
    End If
Next 使用理由

'Sheetに転記
sh.Cells(Lline, 5) = 理由


'その他
sh.Cells(Lline, 6) = txt_自由記入.Value

MsgBox "登録しました。ご協力ありがとうございました。"

End Sub



Private Sub cmd_初期化_Click()

For Each Ctrl In Controls
    L = TypeName(Ctrl)
    If TypeName(Ctrl) = "OptionButton" Or TypeName(Ctrl) = "CheckBox" Then
        Ctrl.Value = False
        
    ElseIf TypeName(Ctrl) = "TextBox" Then
        Ctrl.Value = ""
    End If
Next Ctrl

End Sub

Private Sub opt_サービス認知_その他_Change()

If opt_サービス認知_その他.Value = True Then
    txt_サービス認知_その他.Visible = True
Else
    txt_サービス認知_その他.Visible = False
End If


End Sub

Private Sub opt_職業_その他_Change()

If opt_職業_その他.Value = True Then
    txt_職業_その他.Visible = True
Else
    txt_職業_その他.Visible = False
End If

End Sub

【関連記事】
こちらの記事では「cmd_回答」の処理をＳＱＬ文にして他のＢＯＯＫに保存する方法を記載しております。
bimori466-1.hatenablog.com

ユーザーフォームでアンケート入力のフォームを作る。

１ 閲覧対象者

２ 得られる効果

３ 設計

４ アンケートフォームの作り方

Q1 年齢

Q２ 職業

Q３ サービスをどこで知ったか

Q4 サービスの利用頻度

Q5 サービスの使用理由

Q６ その他記入

回答コマンド

回答初期化コマンド

ユーザーフォームのオブジェクトに名前を付ける。

frame

５ Sheetに転記するためのコードを作成する

Q1 年齢

Q2 職業

Q３ サービスをどこで知ったか

Q４ サービスの利用頻度

Q５ サービスの使用理由

Q６ その他記入

６ 入力エラー判定処理の追加

Q１ 年齢

Q２ 職業

Q3 サービスをどこで知ったか

Q４ サービスの利用頻度

Q５ サービスの使用理由

７ 作ってみて感想

８ 全コード

標準モジュール（呼び出すだけ）

フォームモジュール

１　閲覧対象者

２　得られる効果

３　設計

４　アンケートフォームの作り方

Q1　年齢

Q２　職業

Q３　サービスをどこで知ったか

Q4　サービスの利用頻度

Q5　サービスの使用理由

Q６　その他記入

５　Sheetに転記するためのコードを作成する

Q1　年齢

Q2　職業

Q３　サービスをどこで知ったか

Q４　サービスの利用頻度

Q５　サービスの使用理由

Q６　その他記入

６　入力エラー判定処理の追加

Q１　年齢

Q２　職業

Q3　サービスをどこで知ったか

Q４　サービスの利用頻度

Q５　サービスの使用理由

７　作ってみて感想

８　全コード