自分用のメモです。内容が間違っていたり、作りかけで動作しないコードなどあるのでご注意ください。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
Sub export() ' VBAプロジェクトオブジェクトモデルへのアクセスを信頼する ' 参照設定 Microsoft Visual Basic for Applications Extensibility For Each m In ThisWorkbook.VBProject.VBComponents extension = "" If m.Type = vbext_ct_ClassModule Then extension = "cls" If m.Type = vbext_ct_MSForm Then extension = "frm" If m.Type = vbext_ct_StdModule Then extension = "bas" If extension <> "" Then m.export (ThisWorkbook.Path & "\" & m.Name & "." & extension) Next End Sub |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
With Sheets("集計").PageSetup ' 範囲 .PrintArea = "A1:M" & target_row + 3 ' 余白 .LeftMargin = Application.CentimetersToPoints(1) .RightMargin = Application.CentimetersToPoints(1) .TopMargin = Application.CentimetersToPoints(1) .BottomMargin = Application.CentimetersToPoints(1) .HeaderMargin = Application.CentimetersToPoints(0) .FooterMargin = Application.CentimetersToPoints(0) ' 中央 .CenterHorizontally = True 'CenterVertically ' 向き .Orientation = xlLandscape ' xlPortrait ' ズーム(すべての列を1ページ) .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
Sub get_selected_rows() Set dic = CreateObject("scripting.dictionary") For Each r In Selection If Not dic.exists(r.Row) Then dic.Add r.Row, "" Next ReDim selected_rows(dic.Count - 1) k = dic.keys For i = 0 To dic.Count - 1 selected_rows(i) = k(i) Next i For Each r In selected_rows MsgBox r Next End Sub |
9:00始業なら8:59:59までOKで、9:00の打刻はダメという話を時々聞くが、秒まで記録しない場合はfrom-toどちらも秒を切り捨てるので、9:00の打刻は9:00:00と考えて、問題ないとした方が分かりやすい。
＊＊＊
Ifなどで時刻の条件を書くとき、浮動小数の関係で誤差が生じることがある。セルに入力された値やTimeValue()の値そのままなら問題ないけど、何かしら計算した場合はDateDiff()、あるいはTimeValue()を経由させるなどしたほうが安全。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
Sub test1() Dim tmp As Date tmp = TimeSerial("1", "0", "0") Do While tmp < TimeSerial("22", "00", "0") tmp = DateAdd("n", 1, tmp) Loop Debug.Print Format(tmp, "hh:mm") ' 本来なら22:00になるはずなのに22:01になる End Sub Sub test2() tmp = TimeSerial("1", "0", "0") Do While tmp < TimeSerial("22", "00", "0") tmp = DateAdd("n", 1, tmp) If tmp = TimeSerial("22", "00", "0") Then Debug.Print "Match" ' test1と同じくマッチしない(表示されない) End If Loop ' セルに入力された"22:00"やTimeValue()で作られた22:00ならマッチする End Sub Function test3(tmp As Date) ' tmpはセルに入力された"22:00" If tmp = TimeSerial("22", "00", "0") Then Debug.Print "Match" ' マッチする End If If TimeValue("22:00") = TimeSerial("22", "00", "0") Then Debug.Print "Match" ' マッチする End Function Sub test4() ' 今回のようにループで分を加算した場合の誤差はマイナスのようで、 ' toはマッチ、fromがマッチしない。 Dim tmp As Date tmp = TimeSerial("1", "0", "0") Do While tmp < TimeSerial("23", "00", "0") If tmp >= TimeSerial("22", "00", "0") And tmp <= TimeSerial("22", "15", "0") Then Debug.Print Format(tmp, "hh:mm") ' 22:01 - 22:15 End If tmp = DateAdd("n", 1, tmp) Loop End Sub Function Adjust(tmp) ' これで計算誤差をなくす Adjust = TimeValue(Format(tmp, "hh:mm")) End Function |
＊＊＊
労働時間の計算で15分単位切り捨ての処理をしようとしたが(ちなみに、これは管理会計の話で給与では切り捨てちゃダメ)休憩が15分単位ではなかったので、休憩を挟んで15分をカウントして集計することにした。
こういう計算でループを回すのは悪手だと思うけど、難しいことはできないので、とりあえずループで計算してしまった。。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
Sub test() Call 労働時間("8:00", "11:00", "9:00", "9:02") End Sub Function Adjust(tmp) Adjust = TimeValue(Format(tmp, "hh:mm")) End Function Function 労働時間(出勤 As Date, 退勤 As Date, 外出 As Date, 再入 As Date) ' 出勤調整 If DateDiff("n", 出勤, TimeSerial("8", "0", "0")) > 0 Then 出勤 = TimeSerial("8", "0", "0") workingHour = 0 ' 15分ごとに0.25チャージする counter = 0 Do While DateDiff("n", 出勤, 退勤) > 0 ' 出勤を直接加算している 出勤 = Adjust(出勤) If 出勤 > TimeSerial("10", "0", "0") And 出勤 <= TimeSerial("10", "10", "0") Then ElseIf 出勤 > TimeSerial("12", "0", "0") And 出勤 <= TimeSerial("12", "40", "0") Then ElseIf 出勤 > TimeSerial("15", "0", "0") And 出勤 <= TimeSerial("15", "10", "0") Then ElseIf 出勤 > 外出 And 出勤 <= 再入 Then Else 'Debug.Print Format(出勤, "hh:mm") & "_" & counter counter = counter + 1 End If If counter = 15 Then workingHour = workingHour + 0.25 counter = 0 End If continue: 出勤 = DateAdd("n", 1, 出勤) Loop 労働時間 = workingHour End Function '8:00 '10:00 - 10:10 '12:00 - 12:40 '15:00 - 15:10 '17:00 '11:55～12:50で1チャージとして中に40分の休憩 '14:50～15:15で1チャージとして中に10分の休憩 |
＊＊＊
深夜を入力する場合、VBAでは[h]:mmという表記を扱えないし、セルへの入力でも25:00など入力すると自動で日付が入ってしまうので、セルの書式を文字列に変えてVBAで日付を付加してみた。(今回、セルは時刻だけ入力していたが、セルに日付まで入れてしまったほうが簡単かも知れない)
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
Function FormatTime(arg) Dim h As Integer Dim m As Integer Dim baseDate As Date: baseDate = "1999/1/1" Dim tmp As Date h = CInt(Left(arg, InStr(arg, ":") - 1)) m = CInt(Mid(arg, InStr(arg, ":") + 1)) If h >= 24 Then tmp = DateAdd("d", 1, baseDate) h = h - 24 Else tmp = baseDate End If FormatTime = CDate(tmp & " " & h & ":" & m) End Function Function ArgCheck(arg) ' :が含まれているかどうか If InStr(arg, ":") = 0 Then ArgCheck = False Exit Function End If ' :の左が数値かどうか hh = Left(arg, InStr(arg, ":") - 1) If IsNumeric(hh) = False Then ArgCheck = False Exit Function End If ' :の右が数値かどうか mm = Mid(arg, InStr(arg, ":") + 1) If IsNumeric(mm) = False Then ArgCheck = False Exit Function End If ArgCheck = True End Function Function GetWorkTime(arg1 As String, arg2 As String, arg3 As String, arg4 As String, arg5 As String, arg6 As String, arg7 As String) If arg1 <> "" And arg2 <> "" Then If ArgCheck(arg1) = False Then Err.Raise (1) If ArgCheck(arg2) = False Then Err.Raise (1) Else GetWorkTime = "" Exit Function End If If arg3 <> "" And arg4 <> "" Then If ArgCheck(arg3) = False Then Err.Raise (1) If ArgCheck(arg4) = False Then Err.Raise (1) Else arg3 = "9:00" ' dummy arg4 = "9:00" End If Dim 出勤 As Date Dim 退勤 As Date Dim 外出 As Date Dim 再入 As Date 出勤 = FormatTime(arg1) 退勤 = FormatTime(arg2) 外出 = FormatTime(arg3) 再入 = FormatTime(arg4) ' 出勤調整 If DateDiff("n", 出勤, TimeSerial("8", "0", "0")) > 0 Then 出勤 = TimeSerial("8", "0", "0") workingHour = 0 ' 15分ごとに0.25チャージする counter = 0 Do While DateDiff("n", 出勤, 退勤) > 0 ' 出勤を直接加算している If 出勤 > CDate("1999/1/1 10:00:00") And 出勤 <= CDate("1999/1/1 10:10:00") Then If arg5 = "未" Then counter = counter + 1 ElseIf 出勤 > CDate("1999/1/1 12:00:00") And 出勤 <= CDate("1999/1/1 12:40:00") Then If arg6 = "未" Then counter = counter + 1 ElseIf 出勤 > CDate("1999/1/1 15:00:00") And 出勤 <= CDate("1999/1/1 15:10:00") Then If arg7 = "未" Then counter = counter + 1 ElseIf 出勤 > 外出 And 出勤 <= 再入 Then Else counter = counter + 1 End If If counter = 15 Then workingHour = workingHour + 0.25 counter = 0 End If continue: 出勤 = DateAdd("n", 1, 出勤) Loop GetWorkTime = workingHour End Function '8:00 '10:00 - 10:10 '12:00 - 12:40 '15:00 - 15:10 '17:00 '11:55～12:50で1チャージとして中に40分の休憩 '14:50～15:15で1チャージとして中に10分の休憩 |
いつも忘れてしまうので
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
Sub test() Set w = ThisWorkbook.Sheets("マスタ") r = 3 Do While w.Cells(r, 1).Value <> "" If InStr(w.Cells(r, 1).Value, "、") >= 1 Then ' 含まれていたら tmp = Split(w.Cells(r, 1).Value, "、") ' 文字列を記号で分割 For i = LBound(tmp) To UBound(tmp) ' 配列のループ rr = rr + 1 Next i Else rr = rr + 1 End If r = r + 1 Loop MsgBox rr End Sub |
クリックしたセルの値を取得
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next ' クリックセルの値チェック If Target.Value <> "[削除]" Then Exit Sub ' クリックセルの範囲チェック If Target.Row < 2 Then Exit Sub If Target.Column <> 8 Then Exit Sub ' クリック行の値を取得 id = ActiveSheet.Cells(Target.Row, 1).Value End Sub |
セルの値の変更をチェック
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
Dim beforeValue As Variant Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Target.Column <> 6 Then Exit Sub If beforeValue <> Target.Value Then MsgBox "変更されました" & Chr(13) & Target.Value End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next If Target.Column <> 6 Then Exit Sub beforeValue = Target.Value End Sub |
UserFormからシートのSelectionChangeを拾う場合
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
Private WithEvents e As Application Sub e_SheetSelectionChange(ByVal w As Object, ByVal Target As Range) If ToggleButton1.Value = False Then Exit Sub ' w.Parent.Name ' ブック名 ' w.Name ' シート名 ' Target.Address ' 選択範囲 ' Target.Item(1).Address ' 選択範囲の左上 Debug.Print Target.Item(1).Value r = Target.Item(1).Row TextBox19.Text = w.Cells(r, 1).Value End Sub Sub UserForm_Initialize() Set e = Application End Sub |
全シートを対象に値が含まれる行をコピー
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
Sub Initialize() Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False Application.Calculation = xlCalculationManual ' 関数利用注意 End Sub Sub Finalize() Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True Application.EnableEvents = True Application.ScreenUpdating = True End Sub Sub test1() Initialize '書き込みシート名 writeSheet = "工番集計" ' 1: 10列目に対象を含むか, 2: 11列目が日付として対象と一致するか。 ifValue = 2 ' 最終行が1万より多い場合終了 For Each w In Sheets If w.Cells.SpecialCells(xlLastCell).Row > 10000 Then MsgBox w.Name & "の行数が多いため終了します" Exit Sub End If Next w ' 検索文字列入力 nm = InputBox("値を入力してください") If nm = "" Then Exit Sub If ifValue = 2 And False = IsDate(nm) Then Exit Sub ' 書き込みシート準備 For Each w In Sheets If w.Name = writeSheet Then w.Delete Exit For End If Next w Sheets.Add After:=Sheets(1) ActiveSheet.Name = writeSheet currentRowNumber = 1 ' 探索処理 Dim rg As Range For Each w In Sheets bt = w.Cells.SpecialCells(xlLastCell).Row If bt <= 1 Then GoTo continue: Set rg = w.Range("A1:AA" & bt) For r = 1 To rg.Rows.Count Select Case ifValue Case 1 If InStr(rg.Cells(r, 10).Value, nm) > 0 Then Sheets(writeSheet).Range("A" & currentRowNumber & ":AA" & currentRowNumber).Value = rg.Range("A" & r & ":AA" & r).Value currentRowNumber = currentRowNumber + 1 End If Case 2 If IsDate(rg.Cells(r, 11).Value) Then ' 日付に変換可能 If CDate(rg.Cells(r, 11).Value) = CDate(nm) Then Sheets(writeSheet).Range("A" & currentRowNumber & ":AA" & currentRowNumber).Value = rg.Range("A" & r & ":AA" & r).Value currentRowNumber = currentRowNumber + 1 End If End If End Select Next continue: Next w Sheets(writeSheet).Activate Sheets(writeSheet).Columns.AutoFit Finalize End Sub |
|
1 2 3 4 5 6 7 |
Sub test() For Each w In Sheets w.Cells.Validation.Delete Next End Sub |
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
Sub test() For Each w In Sheets If w.Name = "Sheet2" Then GoTo continue With w.Range("A2:A10").Validation .Delete .Add Type:=xlValidateList, Operator:=xlEqual, Formula1:="テスト1,テスト2" End With continue: Next End Sub |
|
1 2 3 4 5 6 7 8 9 10 11 12 |
Sub test() Set w = ActiveSheet w.Range("A2:K1000").Clear With w.Range("A2:A1000").Validation .Delete .Add Type:=xlValidateList, Operator:=xlEqual, Formula1:="=マスタ!$A$1:$A$776" End With End Sub |
ListBoxの使い方を忘れてしまうので、さっき作ったものをメモ代わり。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
Private Sub CommandButton1_Click() ' 検索 TextBox1.Enabled = False CommandButton1.Enabled = False Set w = Sheets("dat") r = 2 Do While w.Cells(r, 1).Value <> "" If TextBox1.Text = w.Cells(r, 1).Value Then TextBox2.Text = w.Cells(r, 3).Value TextBox3.Text = w.Cells(r, 10).Value TextBox4.Text = w.Cells(r, 11).Value TextBox5.Text = w.Cells(r, 17).Value Label7.caption = r CommandButton2.Enabled = True Call CheckDate Exit Sub End If r = r + 1 Loop TextBox1.Enabled = True CommandButton1.Enabled = True End Sub Sub CheckDate() On Error GoTo exception s = CDate(TextBox3.Text) e = CDate(TextBox4.Text) e = DateAdd("d", 1, e) ' 今日が開始日より後で終了日より前 If s < Now And e > Now Then Label8.caption = "OK" Else Label8.caption = "NG" End If Exit Sub exception: Label8.caption = "-" End Sub Private Sub CommandButton2_Click() ' 今日の日付を登録 Set w = Sheets("dat") If TextBox5.Text <> "" Then result = TextBox5.Text & ", " & Month(Now) & "/" & Day(Now) Else result = Month(Now) & "/" & Day(Now) End If If TextBox6.Text <> "" Then result = result & "(" & TextBox6.Text & ")" End If r = Label7.caption w.Cells(r, 17).Value = result TextBox5.Text = result ' CommandButton2.Enabled = False w.Activate w.Rows(r).Select MsgBox "登録しました。" End Sub Private Sub CommandButton3_Click() ' キャンセル TextBox1.Enabled = True CommandButton1.Enabled = True TextBox1.Text = "" TextBox2.Text = "" TextBox3.Text = "" TextBox4.Text = "" TextBox5.Text = "" TextBox6.Text = "" Label7.caption = "" Label8.caption = "" CommandButton2.Enabled = False TextBox1.SetFocus End Sub Private Sub CommandButton5_Click() ' シート書き込み If ListBox2.ListCount = 0 Then Exit Sub yesNo = vbYes If TextBox2.Text = "" Then yesNo = MsgBox("氏名がありません。登録しますか？", vbYesNo) If yesNo = vbNo Then Exit Sub Set w = Sheets("売上") r = 1 Do While w.Cells(r, 4).Value <> "" ' 商品名で最終行を算出 r = r + 1 Loop targetRow = r memberCode = TextBox1.Text memberName = TextBox2.Text For r = 0 To ListBox2.ListCount - 1 productName = ListBox2.List(r, 0) unitPrice = ListBox2.List(r, 1) amount = ListBox2.List(r, 2) w.Cells(targetRow, 1).Value = DateTime.Now w.Cells(targetRow, 2).Value = memberCode w.Cells(targetRow, 3).Value = memberName w.Cells(targetRow, 4).Value = productName w.Cells(targetRow, 5).Value = unitPrice w.Cells(targetRow, 6).Value = amount targetRow = targetRow + 1 Next r w.Activate w.Rows(targetRow - 1).Select MsgBox "登録しました。" End Sub Private Sub CommandButton6_Click() ' クリア ComboBox1.Text = "" ListBox2.Clear Label12.caption = "" End Sub Private Sub UserForm_Initialize() TextBox1.SetFocus MasterSetup End Sub Sub MasterSetup() ' 商品リスト ListBox1.ColumnCount = 2 Set w = Sheets("master") r = 2 Do While w.Cells(r, 1).Value <> "" productName = w.Cells(r, 1).Value unitPrice = w.Cells(r, 2).Value ListBox1.AddItem "" ListBox1.List(ListBox1.ListCount - 1, 0) = productName ListBox1.List(ListBox1.ListCount - 1, 1) = unitPrice r = r + 1 Loop ' 売上リスト ListBox2.ColumnCount = 4 ' 数量 For i = 1 To 10 ComboBox1.AddItem i Next End Sub Private Sub CommandButton4_Click() ' 転送 If ListBox1.Text = "" Then MsgBox "商品を選択してください。" Exit Sub End If If ComboBox1.Text = "" Then MsgBox "数量を選択してください。" Exit Sub End If productName = ListBox1.List(ListBox1.ListIndex, 0) unitPrice = ListBox1.List(ListBox1.ListIndex, 1) amount = ComboBox1.Text ListBox2.AddItem "" ListBox2.List(ListBox2.ListCount - 1, 0) = productName ListBox2.List(ListBox2.ListCount - 1, 1) = unitPrice ListBox2.List(ListBox2.ListCount - 1, 2) = amount ListBox2.List(ListBox2.ListCount - 1, 3) = CDec(unitPrice) * CDec(amount) TotalPrice End Sub Sub TotalPrice() result = 0 For r = 0 To ListBox2.ListCount - 1 result = CDec(result) + CDec(ListBox2.List(r, 3)) Next r Label12.caption = "\ " & result End Sub |
いつも忘れてしまうのでメモ。
右クリックメニューの階層化。高速化等々。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
Dim caption As String Sub auto_open() On Error Resume Next caption = "会員検索フォーム" For i = 1 To 3 Application.CommandBars("cell").Controls(caption).Delete Next With Application.CommandBars("cell").Controls.Add .OnAction = "show_form" .caption = caption End With Call show_form 'With Application.CommandBars("cell").Controls.Add(Type:=msoControlPopup) ' .caption = "メニュー" ' With .Controls.Add(Type:=msoControlButton) ' .caption = "アイテム" ' .OnAction = "show_form" ' End With 'End With End Sub Sub auto_close() On Error Resume Next For i = 1 To 3 Application.CommandBars("cell").Controls(caption).Delete Next ' Application.CommandBars("cell").Controls("メニュー").Delete End Sub Sub Initialize() Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False Application.Calculation = xlCalculationManual ' 関数利用注意 End Sub Sub Finalize() Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True Application.EnableEvents = True Application.ScreenUpdating = True End Sub |