フォームサンプル8
Private Sub UserForm_Activate()
Me.Repaint '2016-07-10t 追加 フォームの表示を更新
Call 集計
End Sub
Private Sub 集計()
On Error GoTo ErrorHandler
'初期化
Sheets("残高試算表").Range("G14:H112").Value = "" '今期合計クリア
Sheets("残高試算表").Range("k14:l112").Value = "" '決算整理クリア
'2009修正(No.4) 家事関連費の按分率に従い、仕訳帳へ決算仕訳を自動入力
'-----------------------------------------------------------------------
Application.ScreenUpdating = False '画面の更新をオフへ
'仕訳帳のシート保護解除
pss = "aoirohanako08"
Sheets("仕訳帳").Unprotect Password:=pss
Application.EnableEvents = False 'イベントの発生をオフへ
'2016-02-02 バグのため以下削除
'2015-07-09m 仕訳帳に金額(0)で残っている自動仕訳を事前に削除 ※入力後、家事割合0％へ変更された場合
'Set s_siwake = Sheets("仕訳帳")
'Set s_siwake = Nothing
'按分のセルに値が入っているかどうかチェック
'2010修正 0%の場合, 以下の処理はしない
'2011修正(No.22) 2010の修正を元に戻す
For i = 14 To 52 '経費の科目
kanjo_ID = Sheets("残高試算表").Cells(i, 2).Value
If Not (IsNull(Sheets("残高試算表").Cells(i, 4).Value)) And Sheets("残高試算表").Cells(i, 4).Value <> "" And Sheets("残高試算表").Cells(i, 4).Value <> "%" Then
'2010修正 If Not (IsNull(Sheets("残高試算表").Cells(i, 4).Value)) And Sheets("残高試算表").Cells(i, 4).Value <> "" And Sheets("残高試算表").Cells(i, 4).Value <> "%" And Sheets("残高試算表").Cells(i, 4).Value <> "0%" And Sheets("残高試算表").Cells(i, 4).Value <> "0" Then
KANJO_KIN = 0
'2016-04-04m バグの修正 計算式（借方合計×按分率）を（借方合計－貸方合計）×按分率 へ修正
KANJO_KIN_kari = 0 '借方合計
'仕訳帳／借方（G列）を検索
Set myRange = Sheets("仕訳帳").Range("G15:G5015").Find(what:=kanjo_ID, LookIn:=xlValues, LookAt:=xlWhole)
'2013-11m完全一致条件追加（念のため）
'Set myrange = Sheets("仕訳帳").Range("G15:G5014").Find(what:=kanjo_ID, LookIn:=xlValues)
'同じ科目があった場合は、合計値を求める
If Not myRange Is Nothing Then
myAddress = myRange.Address
Do
'2016-04-04m 決算仕訳の値は合計しない
If myRange.Offset(, -2) <> "*" Then
KANJO_KIN_kari = KANJO_KIN_kari + myRange.Offset(, 2).Value
End If
'KANJO_KIN = KANJO_KIN + myrange.Offset(, 2).Value
Set myRange = Sheets("仕訳帳").Range("G15:G5015").FindNext(after:=myRange)
Loop Until myRange.Address = myAddress
End If
'2016-04-04m 追加
KANJO_KIN_kashi = 0 '貸方合計
'仕訳帳／貸方（J列）を検索
Set myRange = Sheets("仕訳帳").Range("J15:J5015").Find(what:=kanjo_ID, LookIn:=xlValues, LookAt:=xlWhole)
'同じ科目があった場合は、合計値を求める
If Not myRange Is Nothing Then
myAddress = myRange.Address
Do
If myRange.Offset(, -5) <> "*" Then
KANJO_KIN_kashi = KANJO_KIN_kashi + myRange.Offset(, 2).Value
End If
Set myRange = Sheets("仕訳帳").Range("J15:J5015").FindNext(after:=myRange)
Loop Until myRange.Address = myAddress
End If
'自動按分計算の金額＝借方合計－貸方合計
KANJO_KIN = KANJO_KIN_kari - KANJO_KIN_kashi
z = 0
'仕訳帳の最終行を取得
end_ro = Sheets("仕訳帳").Range("F5015").End(xlUp).Offset(1).row
'2010追加 end_ro の値が15以下になる場合は、end_ro を15にセットする(仕分帳の最終行)
If end_ro < 15 Then
end_ro = 15
End If
For k = 15 To end_ro
If Sheets("仕訳帳").Cells(k, 3).Value = "12" And Sheets("仕訳帳").Cells(k, 4).Value = "31" And Sheets("仕訳帳").Cells(k, 5).Value = "*" And Sheets("仕訳帳").Cells(k, 6).Value Like "*・家事使用分(自動入力)*" _
And Sheets("仕訳帳").Cells(k, 10).Value = kanjo_ID Then
shiwake_ro = k
z = 1
Exit For
End If
Next k
'仕訳帳に該当行がない場合は、新しい行を最終行に追加する
If z <> 1 Then
shiwake_ro = end_ro
End If
'仕訳帳に反映
'月
Sheets("仕訳帳").Cells(shiwake_ro, 3).Value = "12"
'日
Sheets("仕訳帳").Cells(shiwake_ro, 4).Value = "31"
Sheets("仕訳帳").Cells(shiwake_ro, 5).Value = "*"
'摘要
Sheets("仕訳帳").Cells(shiwake_ro, 6).Value = Sheets("残高試算表").Cells(i, 3) & "・家事使用分(自動入力)"
'借方・番号
Sheets("仕訳帳").Cells(shiwake_ro, 7).Value = "124"
'借方・科目
Sheets("仕訳帳").Cells(shiwake_ro, 8).Value = "事業主貸"
'借方・金額
Sheets("仕訳帳").Cells(shiwake_ro, 9).Value = Application.RoundDown(Sheets("残高試算表").Cells(i, 4).Value * KANJO_KIN, 0)
'貸方・番号
Sheets("仕訳帳").Cells(shiwake_ro, 10).Value = Sheets("残高試算表").Cells(i, 2)
'貸方・科目
Sheets("仕訳帳").Cells(shiwake_ro, 11).Value = Sheets("残高試算表").Cells(i, 3)
'貸方・金額
Sheets("仕訳帳").Cells(shiwake_ro, 12).Value = Application.RoundDown(Sheets("残高試算表").Cells(i, 4).Value * KANJO_KIN, 0)
End If
Next i
'補助科目を持つ科目
gcs = 22 '残高試算表の水道光熱費の開始行
gct = 28 ' 〃 通信費の開始行
gcf = 63 ' 〃 普通預金の開始行
sckr = 9 '仕訳帳 借方金額（I列）
scks = 12 '仕訳帳 貸方金額（L列）
Set range_勘定科目 = Sheets("勘定科目").Range("D16:D19,D22:D26,D35:D40,D44:D50,D55:D59,D68:D70,D73:D75,D78:D101,D104:D110,D116:D139,Q116:Q139")
'仕訳帳の最大行
ShiwakeMaxLine = Sheets("仕訳帳").Range("G5015").End(xlUp).row
'ShiwakeRange = "C15:C" & ShiwakeMaxLine
'借方合計
'----------
For scnt = 15 To ShiwakeMaxLine
kamoku_kari = Sheets("仕訳帳").Cells(scnt, 7).Value
'勘定科目の状態確認
Set krange = range_勘定科目.Find(what:=kamoku_kari, LookAt:=xlWhole)
'Set kRange = Sheets("勘定科目").Range("D16:D19,D22:D26,D35:D40,D44:D50,D55:D59,D68:D70,D73:D75,D78:D101,D104:D110,D116:D139,Q116:Q139").Find(what:=kamoku, LookAt:=xlWhole)
If Not krange Is Nothing Then
kline = krange.row
'kline = Sheets("勘定科目").Range("D16:D19,D22:D26,D35:D40,D44:D50,D55:D59,D68:D70,D73:D75,D78:D101,D104:D110,D116:D139,Q116:Q139").Find(what:=kamoku, LookAt:=xlWhole).Row
'2011.1.5 修正
If Sheets("勘定科目").Cells(kline, 2).Interior.ColorIndex = 45 Or Sheets("勘定科目").Cells(kline, 15).Interior.ColorIndex = 45 Then
Set gRange = Sheets("残高試算表").Range("B14:B112").Find(what:=kamoku_kari, LookAt:=xlWhole)
'今期合計データ（*印なし）
If Not gRange Is Nothing Then
gline = Sheets("残高試算表").Range("B14:B112").Find(what:=kamoku_kari, LookAt:=xlWhole).row
If IsEmpty(Sheets("仕訳帳").Cells(scnt, 5).Value) Then
gl1 = 7 '仕訳帳でE列が空白なら（＝決算仕訳でない）、残高試算表の今期合計・借方合計に集計（G列）
Else
gl1 = 11 '仕訳帳でE列が空白でないなら（＝決算仕訳、通常「*」「°」が入る）残高試算表の決算整理・借方に集計（K列）
End If
Sheets("残高試算表").Cells(gline, gl1).Value = Sheets("残高試算表").Cells(gline, gl1).Value + Sheets("仕訳帳").Cells(scnt, sckr).Value
'水道光熱費の補助科目の場合、普通預金でも集計
If kamoku_kari = 3091 Or kamoku_kari = 3092 Or kamoku_kari = 3093 Or kamoku_kari = 3094 Then
Sheets("残高試算表").Cells(gcs, gl1).Value = Sheets("残高試算表").Cells(gcs, gl1).Value + Sheets("仕訳帳").Cells(scnt, sckr).Value
End If
'通信費の補助科目の場合、普通預金でも集計
If kamoku_kari = 3111 Or kamoku_kari = 3112 Or kamoku_kari = 3113 Or kamoku_kari = 3114 Or kamoku_kari = 3115 Then
Sheets("残高試算表").Cells(gct, gl1).Value = Sheets("残高試算表").Cells(gct, gl1).Value + Sheets("仕訳帳").Cells(scnt, sckr).Value
End If
'普通預金の補助科目の場合、普通預金でも集計
If kamoku_kari = 1041 Or kamoku_kari = 1042 Or kamoku_kari = 1043 Or kamoku_kari = 1044 Or kamoku_kari = 1045 Then
Sheets("残高試算表").Cells(gcf, gl1).Value = Sheets("残高試算表").Cells(gcf, gl1).Value + Sheets("仕訳帳").Cells(scnt, sckr).Value
End If
End If
End If
End If
DoEvents
Next scnt
'貸方合計
'----------
For scnt = 15 To ShiwakeMaxLine
kamoku_kashi = Sheets("仕訳帳").Cells(scnt, 10).Value
'勘定科目の状態確認
Set krange = range_勘定科目.Find(what:=kamoku_kashi, LookAt:=xlWhole)
'Set krange = Sheets("勘定科目").Range("D16:D19,D22:D26,D35:D40,D44:D50,D55:D59,D68:D70,D73:D75,D78:D101,D104:D110,D116:D139,Q116:Q139").Find(what:=kamoku_kashi, LookAt:=xlWhole)
If Not krange Is Nothing Then
kline = krange.row
'2011.1.5 修正
If Sheets("勘定科目").Cells(kline, 2).Interior.ColorIndex = 45 Or Sheets("勘定科目").Cells(kline, 15).Interior.ColorIndex = 45 Then
Set gRange = Sheets("残高試算表").Range("B14:B112").Find(what:=kamoku_kashi, LookAt:=xlWhole)
If Not gRange Is Nothing Then
gline = Sheets("残高試算表").Range("B14:B112").Find(what:=kamoku_kashi, LookAt:=xlWhole).row
'今期合計データ（*印なし）
If IsEmpty(Sheets("仕訳帳").Cells(scnt, 5).Value) Then
gl2 = 8 '仕訳帳でE列が空白なら（＝決算仕訳でない）、残高試算表の今期合計・貸方合計に集計（H列）。
Else
gl2 = 12 '仕訳帳でE列が空白でないなら（＝決算仕訳、通常「*」が入る）残高試算表の決算整理・貸方に集計（L列）。
End If
Sheets("残高試算表").Cells(gline, gl2).Value = Sheets("残高試算表").Cells(gline, gl2).Value + Sheets("仕訳帳").Cells(scnt, scks).Value
'水道光熱費の補助科目の場合、普通預金でも集計（最下段の集計行では、補助科目ははずして関数で集計する）
If kamoku_kashi >= 3091 And kamoku_kashi <= 3094 Then
Sheets("残高試算表").Cells(gcs, gl2).Value = Sheets("残高試算表").Cells(gcs, gl2).Value + Sheets("仕訳帳").Cells(scnt, scks).Value
End If
'通信費の補助科目の場合、普通預金でも集計
If kamoku_kashi = 3111 Or kamoku_kashi = 3112 Or kamoku_kashi = 3113 Or kamoku_kashi = 3114 Or kamoku_kashi = 3115 Then
Sheets("残高試算表").Cells(gct, gl2).Value = Sheets("残高試算表").Cells(gct, gl2).Value + Sheets("仕訳帳").Cells(scnt, scks).Value
End If
'普通預金の補助科目の場合、普通預金でも集計
If kamoku_kashi = 1041 Or kamoku_kashi = 1042 Or kamoku_kashi = 1043 Or kamoku_kashi = 1044 Or kamoku_kashi = 1045 Then
Sheets("残高試算表").Cells(gcf, gl2).Value = Sheets("残高試算表").Cells(gcf, gl2).Value + Sheets("仕訳帳").Cells(scnt, scks).Value
End If
End If
End If
End If
DoEvents
Next scnt
'2009修正(No.15) 開業年チェックの処理
'---------------------------------------
i = 15
Dim kamo_No As String
Dim kamo_Range As Range
'V列の「元入金」残高の消去
Sheets("残高試算表").Range("V60:V111").Value = ""
Do While Sheets("仕訳帳").Cells(i, 10).Value <> ""
kamo_No = 0
kamo_kin = 0
If Sheets("仕訳帳").Cells(i, 10).Value = "223" Then
'相手科目の番号を取得
kamo_No = Sheets("仕訳帳").Range("G" & i).Value
'相手科目の金額を取得
kamo_kin = Sheets("仕訳帳").Range("I" & i).Value
Set kamo_Range = Sheets("残高試算表").Range("B60:B111").Find(what:=kamo_No, LookIn:=xlValues)
If Not kamo_Range Is Nothing Then
Sheets("残高試算表").Cells(kamo_Range.row, 22).Value = kamo_kin + Sheets("残高試算表").Cells(kamo_Range.row, 22).Value
End If
End If
i = i + 1
Loop
集計中表示閉じる:
'2012m追加 完了のメッセージを表示
'----------------------------------
Unload frm_集計中
MsgBox "集計が終わりました。 ", vbOKOnly + vbInformation, "完了"
'2013-11m追加 残高試算表のシート保護
Application.ScreenUpdating = True
pss = "aoirohanako08"
Sheets("残高試算表").Protect DrawingObjects:=True, contents:=True, Scenarios:=True, Password:=pss
Application.EnableEvents = True
'2016-06-29m 以下のチェックは、残高試算表の「集計結果を確認チェック」 へ移行する
'2015-07-09m 資産、負債の科目残高（M60:N110の範囲） がマイナスになったらメッセージを表示
'------------------------------------------------------------------------------------------
'※M60:N110の範囲へ条件書式を設定 マイナスの場合はセルの色をオレンジへ変更
'Set ws = Sheets("残高試算表")
'msg = ""
'
'For r = 60 To 110 '資産・負債の科目（元入金を除く）
' If ws.Cells(r, 13 - (r >= 89)).Value < 0 Then 'セルの値がマイナスだったら
' msg = msg & "科目No. " & ws.Cells(r, 2) & " " & ws.Cells(r, 3) & vbNewLine
' End If
'Next r
'
'If msg <> "" Then
' MsgBox "以下の「勘定科目」の残高がマイナスになっています。入力モレ、入力ミスがないか、確認してください。 " & vbNewLine & "" & vbNewLine _
' & msg, vbOKOnly + vbExclamation, "科目残高エラー"
'End If
'Set ws = Nothing
Exit Sub
ErrorHandler:
If Err.Number > 0 Then
MsgBox "予期せぬエラーが発生しました。Excel を再起動してください。 " & vbNewLine & vbNewLine _
& "No." & Err.Number & " " & Err.Description, vbOKOnly + vbExclamation, "残高試算表の集計"
End If
'残高試算表のシート保護
Application.ScreenUpdating = True
pss = "aoirohanako08"
Sheets("残高試算表").Protect DrawingObjects:=True, contents:=True, Scenarios:=True, Password:=pss
Application.EnableEvents = True
'2013-11m追加 エラーで中断した場合、フォームを閉じる
Unload frm_集計中
End Sub
フォームサンプル7
Option Explicit
'**
' 更新ボタン
' CommandButton1_Click
Private Sub CommandButton1_Click()
Dim Flg As Integer: Flg = 0
Dim i As Integer
' For i = 1 To 2
' MsgBox MdCheckCombox(Me("ComboBox" & i))
' Next i
Debug.Print MdCheckComboxs(Me)
' For i = 1 To 5
' flg = flg + MdCheckText(Me("TextBox" & i))
' Next i
' If MdCheckTexts(Me) = True Then
' MsgBox "未入力箇所があります"
' End If
End Sub
'**
' キャンセルボタン
' CommandButton2_Click
Private Sub CommandButton2_Click()
Unload Me
End Sub
'**
' テキストボックス空欄チェック : 単数
' @param {tBox : MSForms.TextBox} テキストボックス
' @return {FmCheckText : Boolean}
Function FmCheckText(tBox As MSForms.TextBox) As Boolean
With tBox
If .Value = "" Or IsNull(.Value) Then
.BackColor = RGB(245, 200, 238)
FmCheckText = True
Exit Function
End If
End With
FmCheckText = False
End Function
'**
' テキストボックス空欄チェック : 複数
' @return {FmCheckTexts : boolean}
Function FmCheckTexts() As Boolean
Dim Flg As Integer: Flg = 0
Dim myControl As Control
For Each myControl In Controls
If TypeName(myControl) = "TextBox" Then
If myControl.Value = "" Or IsNull(myControl.Value) Then
myControl.BackColor = RGB(245, 200, 238)
Flg = Flg + 1
End If
End If
Next myControl
If Flg > 0 Then
CheckText = True
Else
CheckText = False
End If
End Function
'**
' コンボボックス空欄チェック : 単数
' @param {cBox : MSForms.ComboBox} コンボボックス
' @return {FmCheckCombox : Boolean}
Function FmCheckCombox(cBox As MSForms.ComboBox) As Boolean
With cBox
If .Value = "" Or IsNull(.Value) Then
.BackColor = RGB(245, 200, 238)
FmCheckCombox = True
Exit Function
End If
End With
FmCheckCombox = False
End Function
'**
' コンボボックス空欄チェック : 複数
' @return {FmCheckComboxs : boolean}
Function FmCheckComboxs() As Boolean
Dim Flg As Integer: Flg = 0
Dim myControl As Control
For Each myControl In Controls
If TypeName(myControl) = "ComboBox" Then
If myControl.Value = "" Or IsNull(myControl.Value) Then
myControl.BackColor = RGB(245, 200, 238)
Flg = Flg + 1
End If
End If
Next myControl
If Flg > 0 Then
FmCheckComboxs = True
Else
FmCheckComboxs = False
End If
End Function
Private Sub UserForm_Click()
End Sub
フォームサンプル6
Option Explicit
' **
' ユーザーフォーム初期化
'
Private Sub UserForm_Initialize()
Call Sheet7.LoadData
Call LoadIdList
End Sub
' **
' 更新ボタン処理
'
Private Sub CommandButton1_Click()
If CheckFields Then
Dim p As Person: Set p = New Person
p.Name = TextBox1.Text
p.Birthday = TextBox2.Value
p.Gender = "女"
If OptionButton1.Value = True Then p.Gender = "男"
p.Active = CheckBox1.Value
If ComboBox1.Value = "New" Then
p.Id = Sheet7.MaxId + 1
Call Sheet7.AddPerson(p)
Else
p.Id = ComboBox1.Value
Call Sheet7.UpdatePerson(p)
End If
Call LoadFields(p.Id)
Call LoadIdList
End If
End Sub
' **
' ユーザーフォーム閉じる
'
Private Sub CommandButton2_Click()
Unload Me
End Sub
'**
' コンボボックス変更時の処理切り分け
' (Idが選択時、"New"選択時の処理切り分け)
Private Sub ComboBox1_Change()
With ComboBox1
If IsValidId Then
If IsNumeric(.Value) Then
Call LoadFields(.Value)
Else
Call ClearFields
End If
End If
End With
End Sub
' **
' コンボボックスへのテーブルIDリスト読み込み
'
Private Sub LoadIdList()
With Sheet7.ListObjects(1)
If .ListRows.Count > 1 Then
Dim lists As Variant: lists = .ListColumns(1).DataBodyRange
ComboBox1.List = lists
End If
End With
ComboBox1.AddItem "New"
End Sub
' **
' コンボボックスのId値が正しいかどうか
' (Idが1以上かつ最大値以下または"New"かどうか)
' @return {boolean}
Private Property Get IsValidId() As Boolean
IsValidId = False
With ComboBox1
If (.Value > 0 And .Value <= Sheet7.MaxId) Or (.Value = "New") Then
IsValidId = True
End If
End With
End Property
' **
' 指定Idでのレコードデータの呼び出し
' @param {myId：Long} 呼び出すレコードデータのId値
Private Sub LoadFields(ByVal myId As Long)
With Sheet7.Persons(myId)
ComboBox1.Value = myId
TextBox1.Value = .Name
TextBox2.Value = .Birthday
Call SetGender(.Gender)
CheckBox1.Value = .Active
Label5.Caption = .Age
End With
End Sub
' **
' 性別文字列(男、女)をもとにオプションボタンを設定
' @param {myGender：String} 性別文字列
Private Sub SetGender(ByVal myGender As String)
OptionButton2.Value = True
If myGender = "男" Then OptionButton1.Value = True
End Sub
' **
' 各コントロールの値をクリア
'
Private Sub ClearFields()
TextBox1.Value = ""
TextBox2.Value = ""
OptionButton1.Value = True
CheckBox1.Value = True
Label5.Caption = ""
End Sub
' **
' 各コントロール値が正しく入力されているかどうかを判定する
'
' @return {Boolean}
'
Private Function CheckFields() As Boolean
CheckFields = True
If Not IsValidId Then
MsgBox "「ID」は1以上IDの最大値以下の数値または""New""を入力してください", vbInformation
CheckFields = False
End If
If Len(TextBox1.Text) = 0 Then
MsgBox "「名前」に入力してください", vbInformation
CheckFields = False
End If
If IsDate(TextBox2.Value) Then
MsgBox "「誕生日」には日付を入力してください", vbInformation
CheckFields = False
End If
End Function
フォームサンプル5
Option Explicit
'**
' 閉じるボタン
'------------------------------------------------------------------
Private Sub CommandButton1_Click()
Unload Me
End Sub
'**
' チェックボタン
' チェックボタン内容の確認
'------------------------------------------------------------------
Private Sub CommandButton2_Click()
Dim i As Integer
Dim buf As String
For i = 1 To 9
If Controls("OptionButton" & i) = True Then
buf = buf & Controls("OptionButton" & i).Caption & vbCrLf
End If
Next i
'文字列最後からvbCrLf(2文字分)を除いて抽出
MsgBox Mid(buf, 1, Len(buf) - 2)
End Sub
'**
' チェックボタン
' 配列を使用したチェックボタン内容の確認
'------------------------------------------------------------------
Private Sub CommandButton3_Click()
Dim arr As Variant: arr = Array("りんご", "みかん", "バナナ", "和食", "洋食", "中華", "晴れ", "曇り", "雨")
Dim i As Integer
Dim buf As String
For i = 1 To 9
If Controls("OptionButton" & i) = True Then
buf = buf & arr(i - 1) & vbCrLf
End If
Next i
'文字列最後からvbCrLf(2文字分)を除いて抽出
MsgBox Mid(buf, 1, Len(buf) - 2)
End Sub
'**
' フォーム初期化
' オプションボタンへの動的にgroupname設定
'------------------------------------------------------------------
Private Sub UserForm_Initialize()
With Me
.OptionButton1.Value = True
.OptionButton4.Value = True
.OptionButton7.Value = True
' Dim c As Control
' Dim cnt As Integer, i As Integer
' 'オプションボタン数チェック
' For Each c In .Controls
' If TypeName(c) = "OptionButton" Then
' cnt = cnt + 1
' End If
' Next c
' 'グループ名設定
' For i = 1 To cnt
' With .Controls("OptionButton" & i)
' Select Case i
' Case Is < 4
' .GroupName = "gp1"
' Case Is < 7
' .GroupName = "gp2"
' Case Else
' .GroupName = "gp3"
' End Select
' End With
' Next i
End With
End Sub
■
Option Explicit
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub CommandButton2_Click()
End Sub
Private Sub UserForm_Initialize()
'インデックス番号取得→インデックスより後のシートをコンボボックスに要素追加
With Me.ComboBox1
Dim i As Integer
For i = 1 To Worksheets.Count
If i > SheetIndexCheck("イメージリスト") Then
.AddItem Worksheets(i).Name
End If
Next i
End With
'配列→コンボボックスリスト
With Me.ComboBox2
.List = Array("メニュー1", "メニュー2", "メニュー3", "メニュー4", "メニュー5", "メニュー6", "メニュー7", "メニュー8", "メニュー9", "メニュー10")
End With
'クリア
With Me.ComboBox3
.List = Array("メニュー1", "メニュー2", "メニュー3", "メニュー4", "メニュー5", "メニュー6", "メニュー7", "メニュー8", "メニュー9", "メニュー10")
.Clear
End With
'日付コンボボックス
With Me.ComboBox4
.List = YearArrayCreate()
End With
With Me.ComboBox5
.RowSource = "A2:B13"
End With
End Sub
フォームサンプル3
Option Explicit
'**
' フォーム初期化
'------------------------------------------------------------------
Private Sub UserForm_Initialize()
With Me
.Caption = "サンプルフォーム"
.Width = 300
.Height = 250
End With
End Sub
'**
' 閉じるボタン
'------------------------------------------------------------------
Private Sub CommandButton1_Click()
Unload Me
End Sub
'**
' チェックボタン
' textboxがmultiline設定の場合、「vbCrLf」を置換える
'------------------------------------------------------------------
Private Sub CommandButton2_Click()
With TextBox1
If InStr(.Value, vbLf) > 0 Then
.Text = Replace(.Text, vbCrLf, "")
Else
Debug.Print .Value
End If
End With
End Sub
'**
' フォーカス外れイベント
'------------------------------------------------------------------
Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
With TextBox2
If Len(.Value) < 4 Or Not IsNumeric(.Value) Then
MsgBox "4～8文字の数値を入力してください"
Cancel = True
End If
End With
End Sub
フォームサンプル2
Option Explicit
'**
' フォーム初期化
'------------------------------------------------------------------
Private Sub UserForm_Initialize()
With Me
.Caption = "サンプルフォーム"
.Width = 300
.Height = 250
.CheckBox1.Value = 1
.CheckBox4.Value = 1
End With
End Sub
'**
' 閉じるボタン
'------------------------------------------------------------------
Private Sub CommandButton1_Click()
Unload Me
End Sub
'**
' チェックボタン
'------------------------------------------------------------------
Private Sub CommandButton2_Click()
Dim C As Control
With FormSample2
For Each C In .Controls
If TypeName(C) = "CheckBox" Then
Debug.Print C.Name, C.Value
End If
Next C
Dim i As Integer
For i = 1 To 4
Set C = .Controls("CheckBox" & i)
Debug.Print C.Name, C.Value
Next i
End With
End Sub
