VBA

質問

～フォームの構文～の続きです。

'[確定]ボタンをクリックした時の処理
Private Sub ConfirmButton_Click()

Const NumberColumn As String = "A" '転記先のシートにおいて連番を記入する列の列番号
Const DateColumn As String = "B" '転記先のシートにおいて意見が投書された日付を記入する列の列番号
Const DepartmentColumn As String = "C" '転記先のシートにおいて所属部署名を転記する列の列番号
Const TextColumn As String = "D" '転記先のシートにおいて投書内容を転記する列の列番号
Const myGroupName As String = "DepartmentSelect" '所属部署選択用のオプションボタンのGroupNameプロパティに設定した値
Dim StoragePath As String, PostFileName As String, PostSheetName As String _
, Department As String, myText As String, PostBook As Workbook _
, PostRow As Long, PostingOK As Boolean, myWindow As Window _
, buf As Variant, co As Control, myInformation As String _

Department = "": myText = ""
For Each co In Opinion_Box.Controls
If TypeName(co) = "OptionButton" Then
If co.Value = True And co.GroupName = "DepartmentSelect" Then _
Department = co.Caption
End If
Next co
myText = Contents_of_posting.Value

myInformation = ""
If Department = "" Then myInformation = "選択回答 "
If myText = "" Then myInformation = myInformation & "その他"
myInformation = Replace(RTrim(myInformation), " ", "と")
If myInformation = "" Then

Select Case MsgBox("下記の内容が入力されています。" & vbCrLf _
& "この内容でアンケートを送信してよろしいですか？" & vbCrLf _
& "　[はい] : この内容でアンケートを送信します。" & vbCrLf _
& "　[いいえ] : 入力フォームに戻って投書内容を修正します。" & vbCrLf _
& "　[キャンセル] : 投書を中止して入力フォームを閉じます。" _
& vbCrLf & vbCrLf & "【】 " & Department _
& vbCrLf & vbCrLf & "【】 " & vbCrLf & myText _
, vbYesNoCancel + vbInformation, "アンケート内容確認")
Case vbYes
GoTo Label_Posting
Case vbCancel
Unload Me
End Select
Exit Sub

Else
If MsgBox( _
myInformation & "が入力されていません。" & vbCrLf & vbCrLf _
& "[再試行] : フォームでの入力に戻ります。" & vbCrLf _
& "[キャンセル] : 入力を中止し、フォームを閉じます。" _
, vbRetryCancel + vbExclamation, "未入力項目あり") _
= vbCancel Then Unload Me
Exit Sub
End If

Label_Posting:
myInformation = vbCrLf _
& "フォームに入力いただいた内容を投函することができません。"
Call Confirm_posting_place(myInformation, PostingOK _
, StoragePath, PostFileName, PostSheetName)

With Application
.ScreenUpdating = False
.Calculation = xlManual
.DisplayAlerts = False
End With

buf = ""
On Error Resume Next
Set PostBook = Windows(PostFileName).Parent
buf = PostBook.Path
On Error GoTo 0
If buf = StoragePath Then
Set myWindow = PostBook.Windows(1).NewWindow
Else
Set PostBook = Workbooks.Open(StoragePath & "\" & PostFileName)
Set myWindow = PostBook.Windows(1)
End If
myWindow.Visible = False
With PostBook
.Windows(.Windows.Count).Visible = False
ThisWorkbook.Activate
With .Sheets(PostSheetName)
PostRow = 0
PostRow = .Range(DateColumn & .Rows.Count).End(xlUp).Row + 1
.Range(NumberColumn & PostRow).Value _
= Int(WorksheetFunction.Max(.Columns(NumberColumn))) + 1
With .Range(DateColumn & PostRow)
.Value = Date
.NumberFormatLocal = "ggge""年""m""月""d""日""(aaa)"
End With
.Range(DepartmentColumn & PostRow).Value = Department
.Range(TextColumn & PostRow).Value = myText
End With
End With

With myWindow
.Visible = True
.Parent.Save
.Close
End With
ThisWorkbook.Activate

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With

MsgBox "ありがとうございました！アンケート回答入力内容が送信完了しました。", vbInformation, "完了"
Unload Me

End Sub

以上です。宜しくお願いします。

回答No.2

HohoPapa

ごめんなさい、差し替えます。

問(1)のラジオボタンたちのGroupNameをGr1に
問(2)のラジオボタンたちのGroupNameをGr2に
・・・・
問(6)のラジオボタンたちのGroupNameをGr6に変更し

次のようなコードにすればできると思います。

なお、利用者へのメッセージ表示部分、および
問ごとにラジオボタンを選択したかどうかのチェックは行っていません。
この部分の対応は、もともとのコードの構造がよろしくなく
このコードを生かして対応しようとすると
さらに読みにくいコードになってしまうだろうと思います。

'[確定]ボタンをクリックした時の処理
Private Sub ConfirmButton_Click()
Const DateColumn As String = "B"
Const NumberColumn As String = "A"

Dim StoragePath As String
Dim PostFileName As String
Dim PostSheetName As String
Dim Department(6) As String　'ここ
Dim myText As String
Dim PostBook As Workbook
Dim PostRow As Long
Dim PostingOK As Boolean
Dim myWindow As Window
Dim buf As Variant
Dim co As Control
Dim myInformation As String
Dim QBaseCount As Integer　 'ここ

myText = ""

For QBaseCount = 1 To 6
　Department(QBaseCount) = ""
　For Each co In Opinion_Box.Controls
　 If TypeName(co) = "OptionButton" Then
　　If co.Value = True And co.GroupName = "Gr" & Format(QBaseCount, "0") Then _
　　 Department(QBaseCount) = co.Caption
　 End If
　Next co
Next QBaseCount

myText = Contents_of_posting.Value
myInformation = ""
If Department(1) = "" Then
　myInformation = "選択回答 "
End If

If myText = "" Then
　myInformation = myInformation & "その他"
End If

myInformation = Replace(RTrim(myInformation), " ", "と")

If myInformation = "" Then

　Select Case MsgBox("下記の内容が入力されています。" & vbCrLf _
　& "この内容でアンケートを送信してよろしいですか？" & vbCrLf _
　& "　[はい] : この内容でアンケートを送信します。" & vbCrLf _
　& "　[いいえ] : 入力フォームに戻って投書内容を修正します。" & vbCrLf _
　& "　[キャンセル] : 投書を中止して入力フォームを閉じます。" _
　& vbCrLf & vbCrLf & "【】 " & Department(1) _
　& vbCrLf & vbCrLf & "【】 " & vbCrLf & myText, _
　vbYesNoCancel + vbInformation, "アンケート内容確認")

　 Case vbYes
　 GoTo Label_Posting
　 Case vbCancel
　 Unload Me
　End Select
　Exit Sub

Else

　If MsgBox( _
　myInformation & "が入力されていません。" & vbCrLf & vbCrLf _
　& "[再試行] : フォームでの入力に戻ります。" & vbCrLf _
　& "[キャンセル] : 入力を中止し、フォームを閉じます。", _
　vbRetryCancel + vbExclamation, "未入力項目あり") = _
　vbCancel Then Unload Me
　Exit Sub
End If

Label_Posting:
myInformation = vbCrLf _
& "フォームに入力いただいた内容を投函することができません。"

Call Confirm_posting_place(myInformation, PostingOK, _
　StoragePath, PostFileName, PostSheetName)

With Application
　.ScreenUpdating = False
　.Calculation = xlManual
　.DisplayAlerts = False
End With

buf = ""
On Error Resume Next
Set PostBook = Windows(PostFileName).Parent
buf = PostBook.Path
On Error GoTo 0

If buf = StoragePath Then
　Set myWindow = PostBook.Windows(1).NewWindow
Else
　Set PostBook = Workbooks.Open(StoragePath & "\" & PostFileName)
　Set myWindow = PostBook.Windows(1)
End If

myWindow.Visible = False

With PostBook
　.Windows(.Windows.Count).Visible = False
　ThisWorkbook.Activate

　With .Sheets(PostSheetName)
　 PostRow = 0
　 PostRow = .Range(DateColumn & .Rows.Count).End(xlUp).Row + 1

　 .Cells(PostRow, 1).Value = _
　 Int(WorksheetFunction.Max(.Columns(NumberColumn))) + 1

　 With .Cells(PostRow, 2)
　　.Value = Date
　　.NumberFormatLocal = "ggge""年""m""月""d""日""(aaa)"
　 End With

　 For QBaseCount = 1 To 6
　 .Cells(PostRow, QBaseCount + 2).Value = Department(QBaseCount)
　 Next QBaseCount　 'ここまで

　 .Cells(PostRow, 7).Value = myText
　End With

End With

With myWindow
　.Visible = True
　.Parent.Save
　.Close
End With

ThisWorkbook.Activate

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With

MsgBox "ありがとうございました！アンケート回答入力内容が送信完了しました。", vbInformation, "完了"
Unload Me

End Sub

回答No.1

HohoPapa

問(1)のラジオボタンたちのGroupNameをGr1に
問(2)のラジオボタンたちのGroupNameをGr2に
・・・・
問(6)のラジオボタンたちのGroupNameをGr6に変更し

次のようなコードにすればできると思います。

なお、利用者へのメッセージ表示部分、および
問ごとにラジオボタンを選択したかどうかのチェックは行っていません。
この部分の対応は、もともとのコードの構造がよろしくなく
このコードを生かして対応しようとすると
さらに読みにくいコードになってしまうだろうと思います。

'[確定]ボタンをクリックした時の処理
Private Sub ConfirmButton_Click()

　Dim StoragePath As String
　Dim PostFileName As String
　Dim PostSheetName As String
　Dim Department(6) As String　　
　Dim myText As String
　Dim PostBook As Workbook
　Dim PostRow As Long
　Dim PostingOK As Boolean
　Dim myWindow As Window
　Dim buf As Variant
　Dim co As Control
　Dim myInformation As String
　Dim QBaseCount As Integer　　　

　myText = ""

　For QBaseCount = 1 To 6
　　Department(QBaseCount) = ""
　　For Each co In Opinion_Box.Controls
　　　If TypeName(co) = "OptionButton" Then
　　　　If co.Value = True And co.GroupName = "Gr" & Format(QBaseCount, "0") Then _
　　　　　Department(QBaseCount) = co.Caption
　　　End If
　　Next co
　Next QBaseCount

　myText = Contents_of_posting.Value
　myInformation = ""
　If Department(1) = "" Then
　　myInformation = "選択回答 "
　End If

　If myText = "" Then
　　myInformation = myInformation & "その他"
　End If

　myInformation = Replace(RTrim(myInformation), " ", "と")

　If myInformation = "" Then

　　Select Case MsgBox("下記の内容が入力されています。" & vbCrLf _
　　& "この内容でアンケートを送信してよろしいですか？" & vbCrLf _
　　& "　[はい] : この内容でアンケートを送信します。" & vbCrLf _
　　& "　[いいえ] : 入力フォームに戻って投書内容を修正します。" & vbCrLf _
　　& "　[キャンセル] : 投書を中止して入力フォームを閉じます。" _
　　& vbCrLf & vbCrLf & "【】 " & Department(1) _
　　& vbCrLf & vbCrLf & "【】 " & vbCrLf & myText, _
　　vbYesNoCancel + vbInformation, "アンケート内容確認")

　　　Case vbYes
　　　GoTo Label_Posting
　　　Case vbCancel
　　　Unload Me
　　End Select
　　Exit Sub

　Else

　　If MsgBox( _
　　myInformation & "が入力されていません。" & vbCrLf & vbCrLf _
　　& "[再試行] : フォームでの入力に戻ります。" & vbCrLf _
　　& "[キャンセル] : 入力を中止し、フォームを閉じます。", _
　　vbRetryCancel + vbExclamation, "未入力項目あり") = _
　　vbCancel Then Unload Me
　　Exit Sub
　End If

Label_Posting:
　myInformation = vbCrLf _
　& "フォームに入力いただいた内容を投函することができません。"

　Call Confirm_posting_place(myInformation, PostingOK, _
　　StoragePath, PostFileName, PostSheetName)

　With Application
　　.ScreenUpdating = False
　　.Calculation = xlManual
　　.DisplayAlerts = False
　End With

　buf = ""
　On Error Resume Next
　Set PostBook = Windows(PostFileName).Parent
　buf = PostBook.Path
　On Error GoTo 0

　If buf = StoragePath Then
　　Set myWindow = PostBook.Windows(1).NewWindow
　Else
　　Set PostBook = Workbooks.Open(StoragePath & "\" & PostFileName)
　　Set myWindow = PostBook.Windows(1)
　End If

　myWindow.Visible = False

　With PostBook
　　.Windows(.Windows.Count).Visible = False
　　ThisWorkbook.Activate

　　With .Sheets(PostSheetName)
　　　PostRow = 0
　　　PostRow = .Range(DateColumn & .Rows.Count).End(xlUp).Row + 1

　　　.Cells(PostRow, 1).Value = _
　　　Int(WorksheetFunction.Max(.Columns(NumberColumn))) + 1

　　　With .Cells(PostRow, 2)
　　　　.Value = Date
　　　　.NumberFormatLocal = "ggge""年""m""月""d""日""(aaa)"
　　　End With

　　　For QBaseCount = 1 To 6
　　　 .Cells(PostRow, wkCol + 2).Value = Department(QBaseCount)
　　　Next wkCol　　　'ここまで

　　　.Cells(PostRow, 7).Value = myText
　　End With

　End With

　With myWindow
　　.Visible = True
　　.Parent.Save
　　.Close
　End With

　ThisWorkbook.Activate

　With Application
　 .Calculation = xlAutomatic
　 .ScreenUpdating = True
　 .DisplayAlerts = True
　End With

　MsgBox "ありがとうございました！アンケート回答入力内容が送信完了しました。", vbInformation, "完了"
　Unload Me

End Sub