エクセルVBA ユーザーフォームでアンケートを取る。結果をSQL文で別ＢＯＯＫに転記する。
ユーザーフォームでアンケート入力データを、別BOOKに保存
過去記事で、アンケート入力データを自Sheetに転記する記事を書きました。
今回はアンケート入力結果を自Sheetではなく、他のBOOKに保存します。
変更点のみの解説になります。
目次
１ 閲覧対象者
２ 得られる効果
３ Sheetに転記するためのコードを作成する
４ 作ってみて感想
１ 閲覧対象者
エクセルVBAのユーザーフォームでアンケートマクロを作成したい初心者の人。
アンケート作成例を調べたいという人向けです。
２ 得られる効果
以下の入力フォームから、アンケートを入力し、
別BOOKの「回答集計.xlsx」の「回答集計Sheet」に転記されます。
前回と違い、別のBOOKにSQL文で転記することにより、複数ユーザーの入力が可能です。
マクロ有効BOOKは「共有」の設定をしておきます。
使いどころとしては、職場の部、課、班の共有フォルダに２つのBOOKを格納して、誰でも開けて、アンケート入力がスムーズに行えます。
他社へ展開しても、スムーズに入力していただけるはずです。
BOOKの準備
「マクロ有効Book」と「普通のエクセル」を準備します。
「マクロ有効Book」が、アンケート入力用エクセル。
「普通のエクセル」が、入力結果を転記するエクセルです。ここにデータが溜まります。
３ Sheetに転記するためのコードを作成する
「Q１ 年齢」を例に変更点を解説
前回のSheetに転記する処理の記述は、エラーチェック後にFrame毎のデータを１回１回書き込んでいくというものでした。
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 ’～ 省略 ～ End Sub
今回は各Frameの更新用の値に変数を準備して、最後にSQL文で各項目のデータを更新します。
以下、SQL処理コード
Private Sub cmd_回答_Click() 'ADO接続設定 Dim objCn As New ADODB.Connection Dim strSQL As String With objCn .Provider = "Microsoft.ACE.OLEDB.12.0" .Properties("Extended Properties") = "Excel 12.0" .Open ThisWorkbook.Path & "\" & "回答集計.xlsx" End With 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 '年齢入力 Dim age_InsertSql As String For Each age In Frame_age.Controls If age.Value = True Then If age.Name Like "*10" Then age_InsertSql = age.Caption ElseIf age.Name Like "*20" Then age_InsertSql = age.Caption ElseIf age.Name Like "*30" Then age_InsertSql = age.Caption ElseIf age.Name Like "*40" Then age_InsertSql = age.Caption ElseIf age.Name Like "*50" Then age_InsertSql = age.Caption ElseIf age.Name Like "*60" Then age_InsertSql = age.Caption End If End If Next age '職業 Dim job_InsertSql As String For Each job In Frame_job.Controls If job.Value = True Then If job.Name Like "*主婦" Then job_InsertSql = job.Caption ElseIf job.Name Like "*会社員" Then job_InsertSql = job.Caption ElseIf job.Name Like "*公務員" Then job_InsertSql = job.Caption ElseIf job.Name Like "*自営業" Then job_InsertSql = job.Caption ElseIf job.Name Like "*アルバイト" Then job_InsertSql = job.Caption ElseIf job.Name Like "*学生" Then job_InsertSql = job.Caption ElseIf job.Name Like "*その他" Then job_InsertSql = txt_職業_その他.Value End If End If Next job 'サービス認知 Dim 認知_InsertSql As String For Each サービス認知 In Frame_サービス認知.Controls If サービス認知.Value = True Then If サービス認知.Name Like "*テレビ" Then 認知_InsertSql = サービス認知.Caption ElseIf サービス認知.Name Like "*ラジオ" Then 認知_InsertSql = サービス認知.Caption ElseIf サービス認知.Name Like "*新聞・チラシ" Then 認知_InsertSql = サービス認知.Caption ElseIf サービス認知.Name Like "*SNS" Then 認知_InsertSql = サービス認知.Caption ElseIf サービス認知.Name Like "*ネット" Then 認知_InsertSql = サービス認知.Caption ElseIf サービス認知.Name Like "*口コミ" Then 認知_InsertSql = サービス認知.Caption ElseIf サービス認知.Name Like "*その他" Then 認知_InsertSql = txt_サービス認知_その他.Value End If End If Next サービス認知 'サービス利用頻度 Dim 頻度_InsertSql As String For Each 利用頻度 In Frame_利用頻度.Controls If 利用頻度.Value = True Then If 利用頻度.Name Like "*毎日" Then 頻度_InsertSql = 利用頻度.Caption ElseIf 利用頻度.Name Like "*月1" Then 頻度_InsertSql = 利用頻度.Caption ElseIf 利用頻度.Name Like "*週1" Then 頻度_InsertSql = 利用頻度.Caption End If End If Next 利用頻度 'サービス使用理由 Dim 理由_InsertSql As String For Each 使用理由 In Frame_理由.Controls If 使用理由.Value = True Then If 使用理由.Name Like "*他社" Then If 理由_InsertSql = "" Then 理由_InsertSql = 使用理由.Caption Else 理由_InsertSql = 理由_InsertSql & "," & 使用理由.Caption End If ElseIf 使用理由.Name Like "*評判" Then If 理由_InsertSql = "" Then 理由_InsertSql = 使用理由.Caption Else 理由_InsertSql = 理由_InsertSql & "," & 使用理由.Caption End If ElseIf 使用理由.Name Like "*勝手" Then If 理由_InsertSql = "" Then 理由_InsertSql = 使用理由.Caption Else 理由_InsertSql = 理由_InsertSql & "," & 使用理由.Caption End If ElseIf 使用理由.Name Like "*信頼" Then If 理由_InsertSql = "" Then 理由_InsertSql = 使用理由.Caption Else 理由_InsertSql = 理由_InsertSql & "," & 使用理由.Caption End If End If End If Next 使用理由 'その他 自由記入_InsertSql = txt_自由記入.Value 'SQL文作成 age_InsertSql = "'" & age_InsertSql & "'" job_InsertSql = "'" & job_InsertSql & "'" 認知_InsertSql = "'" & 認知_InsertSql & "'" 頻度_InsertSql = "'" & 頻度_InsertSql & "'" 理由_InsertSql = "'" & 理由_InsertSql & "'" 自由記入_InsertSql = "'" & 自由記入_InsertSql & "'" SQL_VALUES = age_InsertSql & "," & job_InsertSql & "," & 認知_InsertSql & "," & 頻度_InsertSql & "," & 理由_InsertSql & "," & 自由記入_InsertSql strSQL = " INSERT INTO [回答集計$](年齢,職業,サービス認知,サービス利用頻度,サービス使用理由,その他) VALUES(" & SQL_VALUES & ")" 'SQL文実行 objCn.Execute (strSQL) objCn.Close Set objCn = Nothing MsgBox "登録しました。ご協力ありがとうございました。" End Sub
変更点
１ ＡＤＯ接続（回答集計.xlsxに接続するため）用のコード追加
２ 更新用SQL文変数の追加
３ 各Frameループ時の、自Bookへの転記処理を削除
４ SQL文実行
SQL文の文字列結合が面倒ですが、以上で他BOOKへのアンケート結果の転記が可能になります。
４ 作ってみて感想
他BOOKに転記することで「複数の」ユーザーからの入力が可能になりました。
実用性は高まったと思います。
また、転記用のエクセル（ここでは、回答集計.xlsx）は保護しておくことも可能です。
保護しておけば入力データをいじられることも無いです。
改良点は
１ 誰が入力したかを記録する仕組みを作る。
２ 集計方法の自動化を追加。
３ 質問が多い場合、リストを作ってクラスでFrame作る。
改良点３については、記事を作成しようと思います。
まだ、技量が追いついてません。
完成版の記事↓↓
bimori466-1.hatenablog.com
