こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

回答受付中の質問

VBA ユーザーフォーム上のチェックボックスのキャ

皆様、宜しくお願い致します。
私はVBA歴が浅く初心者に近いため、何卒ご教示の程お願い申し上げます。

過去にココで諸先輩方の貴重なアドバイスを頂戴し、お陰様で運用できております。

そこで今回は、現在運用中のユーザーフォームに「チェックボックス」を2つ組み込んで、確定時にこのチェックボックスの選択結果(キャプション)を別のExcelブックである「ご意見箱.xlsx」の「sheet1」の「D列」に反映(転記)させるために、その方法をいろいろと調べているのですが、なかなか該当する情報に辿り着けず困難な状況です。

現在運用中のユーザーフォームのコード記述内容は、下記のとおりです。
※参考までに画面イメージも添付いたします。

皆様、どうかご教示の程お願い申し上げます。


'ユーザーフォームを開いた時の処理(フォームの説明文を表示)
Private Sub UserForm_Activate()

MsgBox "1)の「所属部署選択」欄で所属部署を選択し、" _
& vbCrLf & "2)の「ご意見入力欄」に御意見を入力してから、" _
& vbCrLf & "3)の[確定する]ボタンをクリックして下さい。" _
& vbCrLf & " (入力された内容が別の場所にあるファイルに保存されます。)" _
& vbCrLf & vbCrLf & vbCrLf _
& "※1 [入力内容消去]ボタンをクリックするか、" _
& "入力フォームを閉じると入力した内容を消去する事が出来ます。" _
& vbCrLf & " (消去されるのは、入力フォーム上に表示されている内容のみで、" _
& "一旦投函された投書内容は、別の場所にあるファイルに保存されたままです。)" _
& vbCrLf & vbCrLf & "※2 [キャンセル]ボタンをクリックすると、" _
& "入力を中止して入力フォームを閉じることができます。" _
, vbInformation, "「ご意見箱入力フォーム」の使用方法"

End Sub


'[確定する]ボタンをクリックした時の処理
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


以上です。

投稿日時 - 2017-04-14 13:08:44

QNo.9317444

すぐに回答ほしいです

回答(0)

この質問にはまだ回答がついていません。
あなたが最初に回答してみませんか?