カレンダー入力（UserForm版）
概要
クリックで日付を選ぶミニカレンダー。日付入力ミス防止に有効。
部品コード（UserForm: frmCalendar）
Option Explicit
Public SelectedDate As Date
Private Sub UserForm_Initialize()
Dim d As Date, r As Long, c As Long
d = DateSerial(Year(Date), Month(Date), 1)
Me.Caption = Format(d, "yyyy年 m月")
For r = 0 To 5
For c = 1 To 7
Controls("lbl" & r & "_" & c).Caption = ""
Next
Next
Dim startCol As Long
startCol = Weekday(d)
Dim cur As Long
cur = 1
r = 0: c = startCol
Do While Month(d) = Month(Date)
Controls("lbl" & r & "_" & c).Caption = cur
d = d + 1
cur = cur + 1
c = c + 1
If c = 8 Then
c = 1
r = r + 1
End If
Loop
End Sub
Private Sub lblDate_Click()
If Me.ActiveControl.Caption <> "" Then
SelectedDate = DateSerial(Year(Date), Month(Date), Me.ActiveControl.Caption)
Me.Hide
End If
End Sub
使い方
Dim d
frmCalendar.Show
d = frmCalendar.SelectedDate
If d <> 0 Then Range("B1").Value = d
日付範囲ピッカー（From-To 形式）
部品コード（UserForm: frmDateRange）
Public DateFrom As Variant
Public DateTo As Variant
Private Sub btnOK_Click()
If IsDate(Me.txtFrom) And IsDate(Me.txtTo) Then
DateFrom = CDate(Me.txtFrom)
DateTo = CDate(Me.txtTo)
Me.Hide
Else
MsgBox "日付を正しく入力してください"
End If
End Sub
Private Sub btnCancel_Click()
DateFrom = Empty
DateTo = Empty
Unload Me
End Sub
使い方
frmDateRange.Show
If Not IsEmpty(frmDateRange.DateFrom) Then
Range("A1") = frmDateRange.DateFrom
Range("A2") = frmDateRange.DateTo
End If
プログレスバー（進捗バー）
概要
ループの進捗を可視化するフォーム。
部品コード（UserForm: frmProgress）
ラベル2つ
- lblBar（棒）
- lblMsg（メッセージ）
Sub Progress_Init(msg As String)
frmProgress.lblBar.Width = 0
frmProgress.lblMsg.Caption = msg
frmProgress.Show vbModeless
DoEvents
End Sub
Sub Progress_Set(percent As Double)
frmProgress.lblBar.Width = frmProgress.InsideWidth * percent
DoEvents
End Sub
Sub Progress_Close()
Unload frmProgress
End Sub
使い方
Call Progress_Init("処理中…")
For i = 1 To 1000
Call Progress_Set(i / 1000)
Next i
Call Progress_Close
Excel版「検索ダイアログ」
部品コード（UserForm: frmFind）
テキストボックス：txtKey
リストボックス：lstResult
ボタン：btnSearch
Private Sub btnSearch_Click()
Dim key As String: key = Me.txtKey
Dim ws As Worksheet: Set ws = Sheet1
Dim r As Range, result As Collection, c As Range
Set result = New Collection
For Each c In ws.Range("A1:A2000")
If InStr(c.Value, key) > 0 Then result.Add c
Next
Me.lstResult.Clear
For Each r In result
Me.lstResult.AddItem r.Address & " : " & r.Value
Next
End Sub
使い方
frmFind.Show
Excel版「ログイン画面」
部品コード（UserForm: frmLogin）
txtUser / txtPass
btnOK / btnCancel
Public LoginOK As Boolean
Private Sub btnOK_Click()
If Me.txtUser = "admin" And Me.txtPass = "1234" Then
LoginOK = True
Me.Hide
Else
MsgBox "ログイン情報が正しくありません"
End If
End Sub
Private Sub btnCancel_Click()
LoginOK = False
Unload Me
End Sub
使い方
frmLogin.Show
If frmLogin.LoginOK Then
MsgBox "ログイン成功"
Else
MsgBox "ログイン中止"
End If
一覧 → 詳細画面（List → Detail）
概要
行を選ぶと、詳細フォームに値が入る構成。
部品コード（UserForm: frmList）
リストボックス：lst
Private Sub UserForm_Initialize()
Call UI_SetListBoxFromSheet(Me.lst, Sheet1.Range("A1:C200"))
End Sub
Private Sub lst_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
frmDetail.txtID = Me.lst.List(Me.lst.ListIndex, 0)
frmDetail.txtName = Me.lst.List(Me.lst.ListIndex, 1)
frmDetail.txtQty = Me.lst.List(Me.lst.ListIndex, 2)
frmDetail.Show
End Sub
詳細フォーム（UserForm: frmDetail）
テキストボックス：txtID / txtName / txtQty
行編集フォーム（Add / Edit / Delete）
部品コード（UserForm: frmEdit）
txtID / txtName / txtQty
btnAdd / btnEdit / btnDel
Private Sub btnAdd_Click()
Dim r As Long: r = Cells(Rows.Count, "A").End(xlUp).Row + 1
Cells(r, 1) = txtID
Cells(r, 2) = txtName
Cells(r, 3) = txtQty
MsgBox "追加しました"
End Sub
Private Sub btnEdit_Click()
Dim f As Range
Set f = Columns(1).Find(txtID)
If f Is Nothing Then MsgBox "IDが見つかりません": Exit Sub
f.Offset(0, 1) = txtName
f.Offset(0, 2) = txtQty
MsgBox "更新しました"
End Sub
Private Sub btnDel_Click()
Dim f As Range
Set f = Columns(1).Find(txtID)
If f Is Nothing Then MsgBox "IDが見つかりません": Exit Sub
f.EntireRow.Delete
MsgBox "削除しました"
End Sub
ドロップダウンつき一覧 UI
概要
コンボボックス選択 → リスト表示を絞り込み。
部品コード（UserForm: frmFilterList）
ComboBox：cmb
ListBox：lst
Private Sub UserForm_Initialize()
UI_SetComboList Me.cmb, [{"A","B","C"}]
UI_SetListBoxFromSheet Me.lst, Sheet1.Range("A1:C200")
End Sub
Private Sub cmb_Change()
Dim key As String: key = Me.cmb.Value
Dim src As Range: Set src = Sheet1.Range("A1:C200")
Dim r As Range, buf As Collection, ar()
Set buf = New Collection
For Each r In src.Rows
If r.Cells(1, 2) = key Or key = "" Then
buf.Add r
End If
Next
ReDim ar(1 To buf.Count, 1 To 3)
Dim i As Long: i = 1
For Each r In buf
ar(i, 1) = r.Cells(1, 1)
ar(i, 2) = r.Cells(1, 2)
ar(i, 3) = r.Cells(1, 3)
i = i + 1
Next
Me.lst.List = ar
End Sub
高機能検索フォーム（AND/OR 条件）
概要
2条件＋AND/OR の切替。
部品コード（UserForm: frmAdvSearch）
txt1 / txt2
OptionButton：optAnd / optOr
ListBox：lst
btnSearch
Private Sub btnSearch_Click()
Dim k1 As String: k1 = Me.txt1
Dim k2 As String: k2 = Me.txt2
Dim ANDmode As Boolean: ANDmode = Me.optAnd.Value
Dim src As Range: Set src = Sheet1.Range("A1:C200")
Dim r As Range, res As Collection
Set res = New Collection
For Each r In src.Rows
Dim v As String: v = r.Cells(1, 1).Value
Dim ok As Boolean
If ANDmode Then
ok = (InStr(v, k1) > 0 And InStr(v, k2) > 0)
Else
ok = (InStr(v, k1) > 0 Or InStr(v, k2) > 0)
End If
If ok Then res.Add r
Next
Me.lst.Clear
For Each r In res
Me.lst.AddItem r.Cells(1, 1)
Next
End Sub
