超ド底辺システム管理者の管理人です。
久々にエクセルのマクロの作成依頼を受けましたが・・・
ホントウに久々だったのでほぼ完全に忘れていました。
いちいち簡単なコードでもすっかり忘れているので・・・
ポチポチとネットで調べながらの作業だったので、かなり疲れました。
EXCELで予約受付システム【スタンドアロン】を作る
オーダーは次のとおりです。
- 説明会等の予約をエクセルで付け付けたい
- 日付の指定あり
- 時間帯の指定あり
- 時間帯には人数枠がある
- 当日来ない場合は郵送・その他とする
- 入力項目は、氏名・電話番号・予約日・時間帯・備考
- 適宜集計状況を見たい
こんな感じです。
掛かった時間
VBAのコードをすっかり忘れていたので、一つ一つコードをネットで確認しながらの作業だったので、ほぼ丸一日掛かりました。
ただエラーがでた箇所は・・・
ChatGptに掛ければ修正してくれるので・・・
以前よりは格段に早くできたかと思います。
画面イメージは次のとおりです。
メニューと入力フォーム
入力されるリスト
リアルタイム集計画面
日付ごとに時間帯枠の設定ができます。
定員の設定もできます。
需要があるか分かりませんが・・・
※ご利用は自己責任でお願いします。
コード
いちおうフォームのコードも貼り付けておきます。
Private Sub CommandButton1_Click()
'エラー設定
If UserForm1.Controls("name") = "" Or UserForm1.Controls("howchk") = "" Then
MsgBox "入力されていません"
Exit Sub
Else
End If
'エラー設定
If UserForm1.Controls("howchk") = "説明会" And (UserForm1.Controls("ymdchk") = "" Or UserForm1.Controls("timechk") = "") Then
MsgBox "日時が指定されていません"
Exit Sub
Else
End If
'エラー設定
If UserForm1.Controls("timechk") = "予約時間" Then
MsgBox "時間を正しく設定してください"
Exit Sub
Else
End If
'シートリストの最大行を取得
Dim maxrow As Long
maxrow = Worksheets("list").Cells(Rows.Count, 3).End(xlUp).Row
Worksheets("list").Activate
'フォームの項目をシートlistに転記
' ActiveSheet.Cells(maxrow + 1, 1) = CDate(Format(UserForm1.Controls("ymdchk"), "gee/mm/dd"))
ActiveSheet.Cells(maxrow + 1, 1) = Format(UserForm1.Controls("ymdchk"), "gee/mm/dd")
' ActiveSheet.Cells(maxrow + 1, 1).Offset(0, 1) = CDate(Format(UserForm1.Controls("timechk"), "hh:mm"))
ActiveSheet.Cells(maxrow + 1, 1).Offset(0, 1) = Format(UserForm1.Controls("timechk"), "hh:mm")
ActiveSheet.Cells(maxrow + 1, 1).Offset(0, 2) = UserForm1.Controls("name").Value
ActiveSheet.Cells(maxrow + 1, 1).Offset(0, 3) = UserForm1.Controls("telno").Value
ActiveSheet.Cells(maxrow + 1, 1).Offset(0, 4) = UserForm1.Controls("howchk").Value
ActiveSheet.Cells(maxrow + 1, 1).Offset(0, 5) = UserForm1.Controls("etc").Value
ActiveSheet.Cells(maxrow + 1, 1).Offset(0, 6) = Format(UserForm1.Controls("ymdchk"), "gee/mm/dd") & "-" & Format(UserForm1.Controls("timechk"), "hh:mm")
'フォームをクリア
Call CommandButton2_Click
'シートPIVOTを表示
Worksheets("PIVOT").Activate
'エクセルを全て再計算
Application.Calculate
'シートPIVOTの計算範囲を再指定
Dim ws As Worksheet
Set ws = Worksheets("PIVOT")
Dim pt As PivotTable
Set pt = ws.PivotTables("ピボットテーブル1")
pt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Worksheets("list").Range("A1:G10000"))
'PIVOTテーブルを更新
ActiveWorkbook.RefreshAll
End Sub
Private Sub CommandButton2_Click()
'クリアボタンを押したら
'日付と時間のチェックボックスを再表示せる
UserForm1.ymd.Visible = True
UserForm1.time.Visible = True
'全てのオブジェクトをクリアする
Dim allcontrols As Control
For Each allcontrols In UserForm1.Controls
If TypeName(allcontrols) = "TextBox" Then
allcontrols.Value = ""
ElseIf TypeName(allcontrols) = "CheckBox" Then
allcontrols.Value = False
ElseIf TypeName(allcontrols) = "OptionButton" Then
allcontrols.Value = False
End If
Next allcontrols
'時間のキャプションをリセットする
For i = 1 To 16
UserForm1.Controls("time" & i).Visible = True
UserForm1.Controls("time" & i).Caption = "予約時間"
Next
End Sub
Private Sub how1_Click()
'方法を説明会にする
UserForm1.Controls("howchk") = "説明会"
'日付と時間のオブジェクトを表示にする
UserForm1.ymd.Visible = True
UserForm1.time.Visible = True
End Sub
Private Sub how2_Click()
'郵送をくりっくしたら
'日付と時間のオブジェクトを非表示にする
UserForm1.ymd.Visible = False
UserForm1.time.Visible = False
'方法を郵送にする
UserForm1.Controls("howchk") = "郵送"
'日付と時間を消す
UserForm1.Controls("ymdchk").Value = ""
UserForm1.Controls("timechk").Value = ""
End Sub
Private Sub how3_Click()
'その他をくりっくしたら
'日付と時間のオブジェクトを非表示にする
UserForm1.ymd.Visible = False
UserForm1.time.Visible = False
'方法をその他にする
UserForm1.Controls("howchk") = "その他"
'日付と時間を消す
UserForm1.Controls("ymdchk").Value = ""
UserForm1.Controls("timechk").Value = ""
End Sub
Private Sub UserForm_Initialize()
'ユーザーフォームを読み込んだとき
Dim stname As String
'エクセルの日付シート(dayN)からフォームに日付を表示する
For i = 1 To 5
stname = "day" & i
If Worksheets(stname).Range("B1") <> "" Then
UserForm1.Controls("ymd" & i).Visible = True
UserForm1.Controls("ymd" & i).Caption = Format(Worksheets(stname).Range("B1"), "gee/mm/dd")
Else
UserForm1.Controls("ymd" & i).Visible = False
End If
Next
End Sub
Private Function timeset()
'変数の定義
Dim daycheckbox As Control
Dim stname As String
Dim boxname As String
'時間のオブジェクトを全て表示
For i = 1 To 16
UserForm1.Controls("time" & i).Visible = True
Next
'日付のチェックボックスの内容を確認
For i = 1 To 5
stname = "day" & i
boxname = "ymd" & i
'日付のチェックボックスがTRUEだったら
If UserForm1.Controls(boxname).Value = True Then
UserForm1.Controls("ymdchk") = Format(UserForm1.Controls(boxname).Caption, "gee/mm/dd")
'方法を説明会にする
UserForm1.Controls("howchk") = "説明会"
'該当する日付の予約可能時間帯を表示させる
For j = 1 To 16
If Worksheets(stname).Cells(4 + j, 3) = "する" Then
UserForm1.Controls("time" & j).Caption = Format(Worksheets(stname).Cells(4 + j, 1), "hh:mm") & " 残枠 " & Worksheets(stname).Cells(4 + j, 5)
Else
UserForm1.Controls("time" & j).Visible = False
End If
Next
Else
End If
Next
End Function
Private Sub ymd1_Click()
'日付1を選んだら
Call timeset
End Sub
Private Sub ymd2_Click()
'日付2を選んだら
Call timeset
End Sub
Private Sub ymd3_Click()
'日付3を選んだら
Call timeset
End Sub
Private Sub ymd4_Click()
'日付4を選んだら
Call timeset
End Sub
Private Sub ymd5_Click()
'日付5を選んだら
Call timeset
End Sub
Private Function timeadd()
Dim timebox As Control
For Each timebox In UserForm1.time.Controls
If timebox.Value = True Then
'方法を説明会にする
UserForm1.Controls("howchk") = "説明会"
'時間を取得する
UserForm1.Controls("timechk").Value = Left(timebox.Caption, 5)
Else
End If
Next
End Function
Private Sub time1_Click()
Call timeadd
End Sub
Private Sub time2_Click()
Call timeadd
End Sub
Private Sub time3_Click()
Call timeadd
End Sub
Private Sub time4_Click()
Call timeadd
End Sub
Private Sub time5_Click()
Call timeadd
End Sub
Private Sub time6_Click()
Call timeadd
End Sub
Private Sub time7_Click()
Call timeadd
End Sub
Private Sub time8_Click()
Call timeadd
End Sub
Private Sub time9_Click()
Call timeadd
End Sub
Private Sub time10_Click()
Call timeadd
End Sub
Private Sub time11_Click()
Call timeadd
End Sub
Private Sub time12_Click()
Call timeadd
End Sub
Private Sub time13_Click()
Call timeadd
End Sub
Private Sub time14_Click()
Call timeadd
End Sub
Private Sub time15_Click()
Call timeadd
End Sub
Private Sub time16_Click()
Call timeadd
End Sub
コメント