|
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 |
Function holiday_chk(dt) '通常の休日 If Weekday(dt) = 1 Or Weekday(dt) = 7 Then holiday_chk = True Exit Function End If '祝日 For r = 3 To 30 If Sheets("表紙").Cells(r, 4).Value = dt Then holiday_chk = True Exit Function End If Next r holiday_chk = False End Function Private Sub CommandButton1_Click() '入力チェック -------------------------------------------------------- If IsDate(Sheets("表紙").Cells(3, 2).Value) = False Then MsgBox "開始日が日付ではありません。" Exit Sub End If If IsDate(Sheets("表紙").Cells(6, 2).Value) = False Then MsgBox "終了日が日付ではありません。" Exit Sub End If If Sheets("表紙").Cells(3, 2).Value >= Sheets("表紙").Cells(6, 2).Value Then MsgBox "開始日と終了日の関係が正しくありません。" Exit Sub End If 'ゴミ分別 -------------------------------------------------------- Sheets("ゴミ分別原本(雛形)").Copy after:=Sheets("表紙") Set g = ActiveSheet r = 7 dt = Sheets("表紙").Cells(3, 2).Value Do While dt <= Sheets("表紙").Cells(6, 2).Value f = holiday_chk(dt) '表示形式 If r = 7 Then g.Cells(r, 1).NumberFormatLocal = "yyyy/mm/dd" Else g.Cells(r, 1).NumberFormatLocal = "mm/dd" End If g.Cells(r, 3).NumberFormatLocal = "aaa" '配置 g.Cells(r, 5).HorizontalAlignment = xlCenter g.Cells(r, 6).HorizontalAlignment = xlCenter g.Cells(r, 7).HorizontalAlignment = xlCenter g.Cells(r, 9).HorizontalAlignment = xlCenter '休日の場合 If f = True Then g.Range(g.Cells(r, 1), g.Cells(r, 9)).Interior.Color = RGB(222, 222, 222) '罫線 g.Range(g.Cells(r, 1), g.Cells(r, 9)).Borders.LineStyle = True '値 g.Cells(r, 1).Value = dt '日付 g.Cells(r, 3).Value = dt '曜日 '休日では無い場合 If f = False Then g.Cells(r, 5).Value = "○" '一般廃棄物ゴミ g.Cells(r, 6).Value = "○" '廃プラスチック類 g.Cells(r, 7).Value = "○" '金属くず g.Cells(r, 8).Value = "" '備考 tmp = Int((15 - 9 + 1) * Rnd + 9) g.Cells(r, 9).Value = Sheets("表紙").Cells(tmp, 2).Value 'チェック者 End If r = r + 1 dt = DateAdd("d", 1, dt) Loop '表題 g.Cells(2, 1).Value = " ▼" & Sheets("表紙").Cells(18, 2).Value & "年廃棄物分別チェック表" '作成日 For Each sh In g.Shapes If sh.Type = msoTextBox Then If sh.TextFrame.Characters.Text = "x" Then sh.TextFrame.Characters.Text = "作成日 " & Sheets("表紙").Cells(21, 2).Value End If End If Next '照明チェック -------------------------------------------------------- Sheets("照明チェック(雛形)").Copy after:=Sheets("表紙") Set s = ActiveSheet r = 9 dt = Sheets("表紙").Cells(3, 2).Value Do While dt <= Sheets("表紙").Cells(6, 2).Value f = holiday_chk(dt) '表示形式 If r = 9 Then s.Cells(r, 1).NumberFormatLocal = "yyyy/mm/dd" Else s.Cells(r, 1).NumberFormatLocal = "mm/dd" End If s.Cells(r, 3).NumberFormatLocal = "aaa" '配置 s.Cells(r, 5).HorizontalAlignment = xlCenter s.Cells(r, 6).HorizontalAlignment = xlCenter s.Cells(r, 7).HorizontalAlignment = xlCenter s.Cells(r, 8).HorizontalAlignment = xlCenter s.Cells(r, 9).HorizontalAlignment = xlCenter s.Cells(r, 11).HorizontalAlignment = xlCenter '休日の場合 If f = True Then s.Range(s.Cells(r, 1), s.Cells(r, 11)).Interior.Color = RGB(222, 222, 222) '罫線 s.Range(s.Cells(r, 1), s.Cells(r, 11)).Borders.LineStyle = True '値 s.Cells(r, 1).Value = dt '日付 s.Cells(r, 3).Value = dt '曜日 '休日では無い場合 If f = False Then s.Cells(r, 5).Value = "○" '照明 s.Cells(r, 6).Value = "○" '空調 s.Cells(r, 7).Value = "○" 'マシン s.Cells(r, 8).Value = "○" 'ディスプレイ s.Cells(r, 9).Value = "○" 'プリンタ tmp = Int((15 - 9 + 1) * Rnd + 9) s.Cells(r, 11).Value = Sheets("表紙").Cells(tmp, 2).Value 'チェック者 End If r = r + 1 dt = DateAdd("d", 1, dt) Loop '表題 s.Cells(2, 1).Value = " ▼" & Sheets("表紙").Cells(18, 2).Value & "年省エネチェック表" '作成日 For Each sh In s.Shapes If sh.Type = msoTextBox Then If sh.TextFrame.Characters.Text = "x" Then sh.TextFrame.Characters.Text = "作成日 " & Sheets("表紙").Cells(21, 2).Value End If End If Next End Sub |
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 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 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 |
Sub auto_open() On Error Resume Next '設定シート存在チェック If sheets_exists = False Then Exit Sub 'コンテキスト削除 Application.CommandBars("cell").Controls("承認").Delete Application.CommandBars("cell").Controls("承認").Delete 'コンテキスト初期化 With Application.CommandBars("cell").Controls.Add(Type:=msoControlPopup) .Caption = "承認" With .Controls.Add .Caption = "承認①(" & Sheets("setting").Cells(3, 2).Value & ")" .OnAction = "'approval(3)'" End With With .Controls.Add .Caption = "承認②(" & Sheets("setting").Cells(4, 2).Value & ")" .OnAction = "'approval(4)'" End With With .Controls.Add .Caption = "承認③(" & Sheets("setting").Cells(5, 2).Value & ")" .OnAction = "'approval(5)'" End With With .Controls.Add .Caption = "承認④(" & Sheets("setting").Cells(6, 2).Value & ")" .OnAction = "'approval(6)'" End With With .Controls.Add .Caption = "設定" .OnAction = "setting" End With End With '起動チェック On Error GoTo try With Sheets("setting") OnOff = UCase(.Cells(18, 2).Value) If OnOff = "ON" Then s = .Cells(1, 2).Value 'セル位置1 r = .Cells(3, 2).Value If r <> "" Then v = Sheets(s).Range(r).Value If .Cells(8, 2).Value <> v Then MsgBox "承認されていません。#1" End If 'セル位置2 r = .Cells(4, 2).Value If r <> "" Then v = Sheets(s).Range(r).Value If .Cells(9, 2).Value <> v Then MsgBox "承認されていません。#2" End If 'セル位置3 r = .Cells(5, 2).Value If r <> "" Then v = Sheets(s).Range(r).Value If .Cells(10, 2).Value <> v Then MsgBox "承認されていません。#3" End If 'セル位置4 r = .Cells(6, 2).Value If r <> "" Then v = Sheets(s).Range(r).Value If .Cells(11, 2).Value <> v Then MsgBox "承認されていません。#3" End If End If End With Exit Sub try: MsgBox "起動時の承認が確認できませんでした" End Sub Sub auto_close() On Error Resume Next 'コンテキスト削除 Application.CommandBars("cell").Controls("承認").Delete Application.CommandBars("cell").Controls("承認").Delete '設定シート保護 With Sheets("setting") .Visible = xlVeryHidden .Protect Password:="1234" End With End Sub Sub setting() '設定シート存在チェック If sheets_exists = False Then Exit Sub '表示されていたら非表示 If Sheets("setting").Visible = True Then With Sheets("setting") .Visible = xlVeryHidden .Protect Password:="1234" End With Exit Sub End If '管理者パスワードチェック If admin_chk = False Then Exit Sub With Sheets("setting") '設定シート表示 .Visible = True .Unprotect Password:="1234" 'アクティブ .Activate End With End Sub Function sheets_exists() i = False For Each w In Sheets If w.Name = "setting" Then i = True Next If i = True Then sheets_exists = True ElseIf i = False Then MsgBox "設定シートが存在しません。" sheets_exists = False End If End Function Function admin_chk() admin = "skthskth" pw = InputBox("パスワードを入力してください") If pw = "" Then Exit Function If admin = pw Then admin_chk = True ElseIf admin <> pw Then MsgBox "パスワードが正しくありません。" admin_chk = False End If End Function Function app_pw_chk(p) 'sk4?0? If Len(p) <> 6 Then GoTo e If Left(p, 3) <> "sk4" Then GoTo e If Mid(p, 5, 1) <> "0" Then GoTo e app_pw_chk = True Exit Function e: MsgBox "承認パスワードが違います。" app_pw_chk = False End Function Sub approval(target_row) '設定シート存在チェック If sheets_exists = False Then Exit Sub '承認パスワードチェック p = InputBox("承認者パスワードを入力してください。") If p = "" Then Exit Sub If app_pw_chk(p) = False Then Exit Sub '書き込み On Error GoTo try With Sheets("setting") .Unprotect Password:="1234" s = .Cells(1, 2).Value '承認 r = .Cells(target_row, 2).Value If r = "" Then .Cells(target_row + 5, 2).Value = "" ElseIf r <> "" Then .Cells(target_row + 5, 2).Value = Sheets(s).Range(r).Value End If '承認者 .Cells(target_row + 10, 2).Value = p .Protect Password:="1234" End With Exit Sub try: MsgBox "承認処理が正しく実行されませんでした。" End Sub |
VBA セル内の数式一覧
セル内で使われている数式を抜き出す。
シート１枚ずつ。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
Sub test() Set s1 = ActiveSheet Sheets.Add after:=s1: Set s2 = ActiveSheet For r = 1 To s1.UsedRange.Rows.Count For c = 1 To s1.UsedRange.Columns.Count If InStr(s1.Cells(r, c).Formula, "=") > 0 Then s2.Cells(r, c).Value = "'" & s1.Cells(r, c).Formula Next c Next r End Sub |
全てのシート。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
Sub test() Sheets.Add after:=ActiveSheet Set d = ActiveSheet i = 1 For Each w In Sheets If w.Name <> d.Name Then For r = 1 To w.UsedRange.Rows.Count For c = 1 To w.UsedRange.Columns.Count If InStr(w.Cells(r, c).Formula, "=") > 0 Then d.Cells(i, 1).Value = "'" & w.Cells(r, c).Formula d.Cells(i, 2).Value = "'" & w.Name i = i + 1 End If Next c Next r End If Next End Sub |
VBA 弥生CSV操作
DBに登録。
|
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 |
Application.StatusBar = "データアップロード中..." On Error GoTo try Set con = CreateObject("adodb.connection") con.Open "provider=microsoft.jet.oledb.4.0;data source=" & ActiveWorkbook.Path & "\yayoi.mdb" con.Execute "delete from tbl" Set w = Sheets("貼付") For r = 9 To w.UsedRange.Rows.Count If w.Cells(r, 1).Value = "[明細行]" Then w.Cells(r, 2).NumberFormatLocal = "yyyy/mm/dd" If w.Cells(r, 15).Text = "" Then w.Cells(r, 15).Value = 0 If w.Cells(r, 16).Text = "" Then w.Cells(r, 16).Value = 0 If w.Cells(r, 22).Text = "" Then w.Cells(r, 22).Value = 0 If w.Cells(r, 23).Text = "" Then w.Cells(r, 23).Value = 0 q = "insert into tbl (" & _ "日付,借方勘定科目,借方補助科目,借方部門,借方金額,借方税額,貸方勘定科目,貸方補助科目,貸方部門,貸方金額,貸方税額,摘要" & _ ") values (" & _ "'" & w.Cells(r, 2).Text & "'," & _ "'" & w.Cells(r, 10).Text & "'," & _ "'" & w.Cells(r, 11).Text & "'," & _ "'" & w.Cells(r, 12).Text & "'," & _ " " & w.Cells(r, 15).Text & " ," & _ " " & w.Cells(r, 16).Text & " ," & _ "'" & w.Cells(r, 17).Text & "'," & _ "'" & w.Cells(r, 18).Text & "'," & _ "'" & w.Cells(r, 19).Text & "'," & _ " " & w.Cells(r, 22).Text & " ," & _ " " & w.Cells(r, 23).Text & " ," & _ "'" & w.Cells(r, 24).Text & "');" con.Execute q: Debug.Print q End If Next r If con.State = 1 Then con.Close Application.StatusBar = False InsertDb = True Exit Function try: If con.State = 1 Then con.Close Application.StatusBar = False MsgBox Err.Description InsertDb = False |
DBから取り出す。
|
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 |
Application.StatusBar = "データ取得中..." On Error GoTo try Set con = CreateObject("adodb.connection") Set rec = CreateObject("adodb.recordset") con.Open "provider=microsoft.jet.oledb.4.0;data source=" & ActiveWorkbook.Path & "\yayoi.mdb" Set w = Sheets("集計") w.Activate w.Cells.Delete i = 1 w.Cells(i, 1).Value = "売上" i = w.UsedRange.Rows.Count + 1 rec.Open "select '生産者売上高','-',sum(貸方金額)-sum(貸方税額) from tbl where 貸方勘定科目 = '生産者売上高'", con w.Cells(i, 2).CopyFromRecordset rec rec.Close i = w.UsedRange.Rows.Count + 1 w.Cells(i, 1).Value = "売上/補助" i = w.UsedRange.Rows.Count + 1 rec.Open "select '生産者売上高',貸方補助科目,sum(貸方金額)-sum(貸方税額) from tbl where 貸方勘定科目 = '生産者売上高' group by 貸方補助科目" w.Cells(i, 2).CopyFromRecordset rec rec.Close w.Columns.AutoFit If con.State = 1 Then con.Close Application.StatusBar = False SelectDb = True Exit Function try: If con.State = 1 Then con.Close Application.StatusBar = False MsgBox Err.Description SelectDb = False |
該当アドレスを取り出す。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
Set w = Sheets("集計") For r = 1 To w.UsedRange.Rows.Count If w.Cells(r, 2).Text = op1 And w.Cells(r, 3).Text = op2 Then SearchText = w.Cells(r, 4).Address(rowabsolute:=False, columnabsolute:=False) Exit Function End If Next r SearchText = "A2" |
関数登録
|
1 |
w.Cells(13, 5).Value = "=集計!" & SearchText("業者仕入高", "加工他（買取）") |
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 |
Sub CellsCondition() ' 条件付書式クリア Set w = Sheets("11月") 'w.Cells.FormatConditions.Delete w.Columns("J").FormatConditions.Delete ' 最終行取得 'b = w.UsedRange.Rows.Count b = 324 For r = 2 To b For c = 10 To 10 ' J列のみ ' A列の値(Weekday)が1なら赤 'Set f = w.Cells(r, c).FormatConditions.Add(xlExpression, xlEqual, "=Weekday(A" & r & ")=1") 'f.Interior.Color = RGB(255, 200, 200) 'f.StopIfTrue = False ' A列の値(Weekday)が7なら青(複数条件) 'Set f = w.Cells(r, c).FormatConditions.Add(xlExpression, xlEqual, "=AND(B" & r & "=0,Weekday(A" & r & ")=7)") 'f.Interior.Color = RGB(200, 200, 255) 'f.StopIfTrue = False ' 重複チェック＋特定の単語を除外 'Set f = w.Cells(r, c).FormatConditions.Add(xlExpression, xlEqual, "=AND(COUNTIF(J2:J324,J" & r & ")>1,J" & r & "<>""ｼｺﾐ"")") 'f.Interior.Color = RGB(255, 0, 0) 'f.StopIfTrue = False ' A列の値が1なら書式設定 'Set f = w.Cells(r, 1).FormatConditions.Add(xlExpression, xlEqual, "=Day(A" & r & ")=1") 'f.NumberFormat = "mm/dd(aaa)" 'f.StopIfTrue = False Next c Next r End Sub |
VBA 工数管理プログラム 変更版
前回作成したファイルにマスタ管理機能を追加しフォームを少し変更。
Module1
|
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 |
Sub auto_open() SetStyle If (StrConv(Sheets("設定").Range("B5").Value, 10) = "on") Then Sheets("作業登録").Activate UserForm1.Show End If On Error Resume Next Application.CommandBars("cell").Controls("フォーム表示").Delete Application.CommandBars("cell").Controls("フォーム表示").Delete With Application.CommandBars("cell").Controls.Add .Caption = "フォーム表示" .OnAction = "FormShow" End With End Sub Sub auto_close() On Error Resume Next Application.CommandBars("cell").Controls("フォーム表示").Delete Application.CommandBars("cell").Controls("フォーム表示").Delete End Sub Sub FormShow() Sheets("作業登録").Activate UserForm1.Show End Sub Sub SetStyle() 'マスタ管理 Sheets("マスタ管理").Cells(3, 2).NumberFormatLocal = "@" '登録者 Sheets("登録者").Cells(3, 2).NumberFormatLocal = "@" Sheets("登録者").Cells(5, 2).NumberFormatLocal = "@" Sheets("登録者").Cells(7, 2).NumberFormatLocal = "@" Sheets("登録者").Cells(11, 2).NumberFormatLocal = "@" '作業登録 Sheets("作業登録").Cells.NumberFormatLocal = "" Sheets("作業登録").Columns("A").NumberFormatLocal = "@" Sheets("作業登録").Columns("B").NumberFormatLocal = "@" For c = 8 To 101 Step 3 Sheets("作業登録").Cells(1, c).Value = "種" Sheets("作業登録").Cells(1, c + 1).Value = "スタート" Sheets("作業登録").Cells(1, c + 2).Value = "ストップ" Sheets("作業登録").Columns(c).NumberFormatLocal = "" Sheets("作業登録").Columns(c + 1).NumberFormatLocal = "mm/dd hh:mm" Sheets("作業登録").Columns(c + 2).NumberFormatLocal = "mm/dd hh:mm" Sheets("作業登録").Columns(c).ColumnWidth = "2.5" Sheets("作業登録").Columns(c + 1).ColumnWidth = "12" Sheets("作業登録").Columns(c + 2).ColumnWidth = "12" Next c End Sub Sub WorkTimeAdd() Set w = Sheets("作業登録") For r = 2 To w.UsedRange.Rows.Count w.Cells(r, 5) = "" w.Cells(r, 6) = "" If w.Cells(r, 4).Text = "完了" And w.Cells(r, 7).Text <> "" Then n = 0 f = 0 For c = 8 To w.Cells(r, 7).Text Step 3 Select Case w.Cells(r, c).Text Case "作" n = n + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text) Case "修" f = f + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text) End Select Next c w.Cells(r, 5) = Int(n / 60) & "." & Format(n Mod 60, "00") & " H" w.Cells(r, 6) = Int(f / 60) & "." & Format(f Mod 60, "00") & " H" End If Next r w.Activate End Sub Function WorkTime(date_s, date_e) On Error GoTo try date_s = CDate(date_s) date_e = CDate(date_e) ts = 0 Do While date_s < date_e ts = ts + 1 If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:00:00") And _ date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:15:00") Then ts = ts - 1 End If If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:00:00") And _ date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:50:00") Then ts = ts - 1 End If If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:00:00") And _ date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:15:00") Then ts = ts - 1 End If If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:20:00") And _ date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:30:00") Then ts = ts - 1 End If date_s = DateAdd("n", 1, date_s) Loop WorkTime = ts Exit Function try: WorkTime = 0 End Function |
UserForm1
|
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 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 |
Function form_query() On Error GoTo try Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" rs.Open "select ID,customer,model,serial,quantity,notes from orders where serial = '" & UserForm1.TextBox1.Text & "';", cn Do Until rs.EOF UserForm1.TextBox8.Text = rs(0) UserForm1.TextBox2.Text = rs(1) UserForm1.TextBox3.Text = rs(2) UserForm1.TextBox1.Text = rs(3) UserForm1.TextBox7.Text = rs(4) UserForm1.TextBox4.Text = rs(5) rs.movenext Loop If UserForm1.TextBox8.Text <> "" And UserForm1.TextBox7.Text > 0 Then For i = 1 To UserForm1.TextBox7.Text UserForm1.ComboBox2.AddItem i UserForm1.ComboBox3.AddItem i Next i UserForm1.ComboBox2.Text = "1" UserForm1.ComboBox3.Text = UserForm1.TextBox7.Text End If If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing form_query = True Exit Function try: If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox Err.Description form_query = False End Function Private Sub CommandButton1_Click() Sheets("作業登録").Activate If UserForm1.TextBox1.Text = "" Then MsgBox "工番を入力してください。" Exit Sub End If If db_chk = False Then Exit Sub form_clear form_query End Sub Sub form_clear() UserForm1.TextBox8.Text = "" UserForm1.TextBox2.Text = "" UserForm1.TextBox3.Text = "" UserForm1.TextBox7.Text = "" UserForm1.TextBox4.Text = "" UserForm1.ComboBox2.Clear UserForm1.ComboBox3.Clear UserForm1.ComboBox2.Text = "" UserForm1.ComboBox3.Text = "" UserForm1.ComboBox1.Text = "" End Sub Function db_chk() On Error GoTo try Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" If cn.state = 1 Then cn.Close Set cn = Nothing db_chk = True Exit Function try: If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox "DBに接続できません。" db_chk = False End Function Function qty_parse() On Error GoTo try If UserForm1.ComboBox2.Text = "" Or UserForm1.ComboBox3.Text = "" Then MsgBox "対象枝を入力してください。" qty_parse = False Exit Function End If qty = CInt(UserForm1.TextBox7.Text) suffix_s = CInt(UserForm1.ComboBox2.Text) suffix_e = CInt(UserForm1.ComboBox3.Text) If suffix_s = 0 Or suffix_e = 0 Then MsgBox "対象枝は1以上の数字を指定する必要があります。" qty_parse = False Exit Function End If If suffix_e > qty Or suffix_s > suffix_e Then MsgBox "対象枝の指定範囲に問題があります。" qty_parse = False Exit Function End If qty_parse = True Exit Function try: MsgBox "対象枝が数字ではありません。" qty_parse = False End Function Private Sub CommandButton2_Click() Sheets("作業登録").Activate Call MainWrite("1", "スタート", "作") MsgBox "完了しました。" End Sub Private Sub CommandButton3_Click() Sheets("作業登録").Activate Call MainWrite("1", "スタート", "修") MsgBox "完了しました。" End Sub Private Sub CommandButton4_Click() Sheets("作業登録").Activate Call MainWrite("3", "ストップ", "") MsgBox "完了しました。" End Sub Private Sub CommandButton5_Click() Sheets("作業登録").Activate Call MainWrite("4", "完了", "") MsgBox "完了しました。" End Sub Private Sub CommandButton6_Click() Sheets("作業登録").Activate UserForm1.TextBox1.Text = "" form_clear End Sub Private Sub CommandButton7_Click() Sheets("作業登録").Activate WorkTimeAdd MsgBox "完了しました。" End Sub Sub MainWrite(mark, state, typ) If ActiveSheet.Name <> "作業登録" Then MsgBox "作業登録で実施してください。" Exit Sub End If If UserForm1.TextBox8.Text = "" Then MsgBox "対象のIDが空白です。取得してください。" Exit Sub End If If UserForm1.ComboBox1.Text = "" Then MsgBox "作業者を選んでください。" Exit Sub End If If qty_parse = False Then Exit Sub Set w = Sheets("作業登録") serial = UserForm1.TextBox1.Text worker = UserForm1.ComboBox1.Text For suffix = CInt(UserForm1.ComboBox2.Text) To CInt(UserForm1.ComboBox3.Text) f = False For r = 2 To w.UsedRange.Rows.Count If worker = w.Cells(r, 1).Text And serial = w.Cells(r, 2).Text And suffix = w.Cells(r, 3) Then f = True Call WriteCol(r, worker, serial, suffix, mark, state, typ) w.Cells(r, 1).Select End If Next r If f = False Then Call WriteCol(r, worker, serial, suffix, mark, state, typ) w.Cells(r, 1).Select End If Next suffix End Sub Sub WriteCol(r, worker, serial, suffix, mark, state, typ) Set w = Sheets("作業登録") If w.Cells(r, 4).Value = "完了" Then MsgBox serial & "-" & suffix & "は既に完了しています。" Exit Sub End If Select Case mark Case "1" '作業スタート If w.Cells(r, 4).Value = "スタート" Then MsgBox serial & "-" & suffix & "は既にスタートしています。" Exit Sub End If If w.Cells(r, 4).Value = "" Or w.Cells(r, 4).Value = "ストップ" Then c = 9 End If Case "2" '修正スタート If w.Cells(r, 4).Value = "スタート" Then MsgBox serial & "-" & suffix & "は既にスタートしています。" Exit Sub End If If w.Cells(r, 4).Value = "" Or w.Cells(r, 4).Value = "ストップ" Then c = 9 End If Case "3" 'ストップ If w.Cells(r, 4).Value = "スタート" Then c = 10 End If If w.Cells(r, 4).Value = "" Or w.Cells(r, 4).Value = "ストップ" Then MsgBox serial & "-" & suffix & "はスタートしていません。" Exit Sub End If Case "4" '指定工番の完了 If w.Cells(r, 4).Value = "スタート" Then MsgBox serial & "-" & suffix & "はスタートしているため完了できません。" Exit Sub End If If w.Cells(r, 4).Value = "ストップ" Or w.Cells(r, 4).Value = "" Then w.Cells(r, 1).Value = worker w.Cells(r, 2).Value = serial w.Cells(r, 3).Value = suffix w.Cells(r, 4).Value = "完了" w.Cells(r, 4).Interior.ColorIndex = 0 Exit Sub End If End Select Do While True If w.Cells(r, c).Value = "" Then w.Cells(r, 1).Value = worker w.Cells(r, 2).Value = serial w.Cells(r, 3).Value = suffix w.Cells(r, 4).Value = state If (mark = 1 Or mark = 2) Then 'スタート w.Cells(r, 4).Interior.Color = RGB(255, 0, 0) w.Cells(r, 7).Value = "" w.Cells(r, c - 1).Value = typ End If If (mark = 3) Then 'ストップ w.Cells(r, 4).Interior.Color = RGB(255, 255, 0) w.Cells(r, 7).Value = c - 2 End If w.Cells(r, c).Value = Format(Now(), "yyyy/mm/dd hh:mm:00") Exit Do End If c = c + 3 Loop End Sub Private Sub UserForm_Initialize() On Error GoTo try UserForm1.ComboBox1.Clear Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" rs.Open "select ID,worker from worker;", cn Do Until rs.EOF If rs(1) <> "" Then UserForm1.ComboBox1.AddItem rs(1) End If rs.movenext Loop If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing Exit Sub try: If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox Err.Description End Sub |
Sheet5(マスタ管理)
|
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 |
Function BuildQuery(mark) q_i = Sheets("マスタ管理").Range("B9").Value q_c = Sheets("マスタ管理").Range("B3").Value q_i = StrConv(q_i, vbNarrow) q_i = Replace(q_i, "'", "’") q_c = Replace(q_c, "'", "’") q_i = Replace(q_i, """", "’") q_c = Replace(q_c, """", "’") If mark = "s" Then q = "select ID,worker from worker;" If mark = "i" Then q = "insert into worker (worker) values ('" & q_c & "');" If mark = "u" Then q = "update worker set worker = '" & q_c & "' where ID = " & q_i & ";" If mark = "d" Then q = "delete from worker where ID = " & q_i & ";" BuildQuery = q End Function Private Sub CommandButton1_Click() If db_chk = False Then Exit Sub If form_chk = False Then Exit Sub If form_query("i") = False Then Exit Sub grid_clear If grid_load("s") = False Then Exit Sub form_clear End Sub Private Sub CommandButton2_Click() If db_chk = False Then Exit Sub If id_chk = False Then Exit Sub If form_chk = False Then Exit Sub If form_query("u") = False Then Exit Sub grid_clear If grid_load("s") = False Then Exit Sub form_clear End Sub Private Sub CommandButton3_Click() If db_chk = False Then Exit Sub If id_chk = False Then Exit Sub yn = MsgBox("削除しますか？", vbYesNo) If yn = vbNo Then Exit Sub If form_query("d") = False Then Exit Sub grid_clear If grid_load("s") = False Then Exit Sub form_clear End Sub Function id_chk() On Error GoTo try If Sheets("マスタ管理").Range("B9").Value = "" Then GoTo try v = CLng(Sheets("マスタ管理").Range("B9").Value) id_chk = True Exit Function try: MsgBox "IDが正しくありません。" id_chk = False End Function Function form_chk() If Sheets("マスタ管理").Range("B3").Value = "" Then GoTo try form_chk = True Exit Function try: MsgBox "入力が不足しています。" form_chk = False End Function Sub grid_clear() Sheets("マスタ管理").Range("G4:H100").Delete End Sub Sub form_clear() Sheets("マスタ管理").Range("B3").Value = "" Sheets("マスタ管理").Range("B9").Value = "" End Sub Function form_query(mark) On Error GoTo try Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" cn.Execute BuildQuery(mark) If cn.state = 1 Then cn.Close Set cn = Nothing form_query = True Exit Function try: If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox Err.Description form_query = False End Function Function grid_load(mark) On Error GoTo try Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" rs.Open BuildQuery(mark), cn r = 4 Do Until rs.EOF Sheets("マスタ管理").Cells(r, 7).Value = rs(0) Sheets("マスタ管理").Cells(r, 8).Value = rs(1) Sheets("マスタ管理").Range("G" & r & ":H" & r & "").Borders.LineStyle = True r = r + 1 rs.movenext Loop If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing grid_load = True Exit Function try: If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing grid_load = False End Function Function db_chk() On Error GoTo try Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" If cn.state = 1 Then cn.Close Set cn = Nothing db_chk = True Exit Function try: If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox "DBに接続できません。" db_chk = False End Function Private Sub CommandButton4_Click() If db_chk = False Then Exit Sub grid_clear If grid_load("s") = False Then Exit Sub form_clear End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row >= 4 And Target.Column = 7 And Target.Text <> "" Then ActiveSheet.Cells(3, 2).Value = ActiveSheet.Cells(Target.Row, 8).Value ActiveSheet.Cells(9, 2).Value = ActiveSheet.Cells(Target.Row, 7).Value ElseIf Target.Row >= 4 And Target.Column = 7 And Target.Text = "" Then ActiveSheet.Cells(3, 2).Value = "" ActiveSheet.Cells(9, 2).Value = "" End If End Sub |
Sheet3(作業登録)
|
1 2 3 4 5 6 7 8 |
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If UserForm1.Visible And UserForm1.TextBox8.Text = "" And _ Target.Row >= 2 And Target.Column = 2 And Target.Text <> "" Then UserForm1.TextBox1.Text = Target.Text End If End Sub |
Sheet1(登録者)
|
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 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
Function BuildQuery(mark) q_i = Sheets("登録者").Range("B21").Value q_c = Sheets("登録者").Range("B3").Value q_m = Sheets("登録者").Range("B5").Value q_s = Sheets("登録者").Range("B7").Value q_q = Sheets("登録者").Range("B9").Value q_n = Sheets("登録者").Range("B11").Value q_i = StrConv(q_i, vbNarrow) q_s = StrConv(q_s, vbNarrow) q_q = StrConv(q_q, vbNarrow) q_i = Replace(q_i, "'", "’") q_c = Replace(q_c, "'", "’") q_m = Replace(q_m, "'", "’") q_s = Replace(q_s, "'", "’") q_q = Replace(q_q, "'", "’") q_n = Replace(q_n, "'", "’") q_i = Replace(q_i, """", "’") q_c = Replace(q_c, """", "’") q_m = Replace(q_m, """", "’") q_s = Replace(q_s, """", "’") q_q = Replace(q_q, """", "’") q_n = Replace(q_n, """", "’") If mark = "s1" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'true';" If mark = "s2" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'false';" If mark = "i" Then q = "insert into orders (customer,model,serial,quantity,notes,visible) values ('" & q_c & "','" & q_m & "','" & q_s & "'," & q_q & ",'" & q_n & "','true');" If mark = "u" Then q = "update orders set customer = '" & q_c & "', model = '" & q_m & "', serial = '" & q_s & "', quantity = " & q_q & ", notes = '" & q_n & "' where ID = " & q_i & ";" If mark = "d" Then q = "delete from orders where ID = " & q_i & ";" If mark = "h" Then q = "update orders set visible = 'false' where ID = " & q_i & ";" BuildQuery = q End Function Private Sub CommandButton6_Click() If db_chk = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Private Sub CommandButton5_Click() If db_chk = False Then Exit Sub grid_clear If grid_load("s2") = False Then Exit Sub form_clear End Sub Private Sub CommandButton1_Click() If db_chk = False Then Exit Sub If form_chk = False Then Exit Sub If qty_parse = False Then Exit Sub If form_query("i") = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Private Sub CommandButton2_Click() If db_chk = False Then Exit Sub If id_chk = False Then Exit Sub If form_chk = False Then Exit Sub If qty_parse = False Then Exit Sub If form_query("u") = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Private Sub CommandButton3_Click() If db_chk = False Then Exit Sub If id_chk = False Then Exit Sub yn = MsgBox("削除しますか？", vbYesNo) If yn = vbNo Then Exit Sub If form_query("d") = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Private Sub CommandButton4_Click() If db_chk = False Then Exit Sub If id_chk = False Then Exit Sub If form_query("h") = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Function id_chk() On Error GoTo try If Sheets("登録者").Range("B21").Value = "" Then GoTo try v = CLng(Sheets("登録者").Range("B21").Value) id_chk = True Exit Function try: MsgBox "IDが正しくありません。" id_chk = False End Function Function form_chk() If Sheets("登録者").Range("B3").Value = "" Then GoTo try If Sheets("登録者").Range("B5").Value = "" Then GoTo try If Sheets("登録者").Range("B7").Value = "" Then GoTo try If Sheets("登録者").Range("B9").Value = "" Then GoTo try form_chk = True Exit Function try: MsgBox "入力が不足しています。" form_chk = False End Function Sub grid_clear() Sheets("登録者").Range("G4:L1000").Delete End Sub Sub form_clear() Sheets("登録者").Range("B3").Value = "" Sheets("登録者").Range("B5").Value = "" Sheets("登録者").Range("B7").Value = "" Sheets("登録者").Range("B9").Value = "" Sheets("登録者").Range("B11").Value = "" Sheets("登録者").Range("B21").Value = "" End Sub Function qty_parse() On Error GoTo try qty = CLng(Sheets("登録者").Range("B9").Value) If qty = 0 Then GoTo try qty_parse = True Exit Function try: MsgBox "数量が正しくありません。" qty_parse = False End Function Function form_query(mark) On Error GoTo try Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" cn.Execute BuildQuery(mark) If cn.state = 1 Then cn.Close Set cn = Nothing form_query = True Exit Function try: If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox Err.Description form_query = False End Function Function grid_load(mark) On Error GoTo try Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" rs.Open BuildQuery(mark), cn r = 4 Do Until rs.EOF Sheets("登録者").Cells(r, 7).Value = rs(0) Sheets("登録者").Cells(r, 8).Value = rs(1) Sheets("登録者").Cells(r, 9).Value = rs(2) Sheets("登録者").Cells(r, 10).Value = rs(3) Sheets("登録者").Cells(r, 11).Value = rs(4) Sheets("登録者").Cells(r, 12).Value = rs(5) Sheets("登録者").Range("G" & r & ":L" & r & "").Borders.LineStyle = True r = r + 1 rs.movenext Loop If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing grid_load = True Exit Function try: If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing grid_load = False End Function Function db_chk() On Error GoTo try Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" If cn.state = 1 Then cn.Close Set cn = Nothing db_chk = True Exit Function try: If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox "DBに接続できません。" db_chk = False End Function Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row >= 4 And Target.Column = 7 And Target.Text <> "" Then ActiveSheet.Cells(3, 2).Value = ActiveSheet.Cells(Target.Row, 8).Value ActiveSheet.Cells(5, 2).Value = ActiveSheet.Cells(Target.Row, 9).Value ActiveSheet.Cells(7, 2).Value = ActiveSheet.Cells(Target.Row, 10).Value ActiveSheet.Cells(9, 2).Value = ActiveSheet.Cells(Target.Row, 11).Value ActiveSheet.Cells(11, 2).Value = ActiveSheet.Cells(Target.Row, 12).Value ActiveSheet.Cells(21, 2).Value = ActiveSheet.Cells(Target.Row, 7).Value ElseIf Target.Row >= 4 And Target.Column = 7 And Target.Text = "" Then ActiveSheet.Cells(3, 2).Value = "" ActiveSheet.Cells(5, 2).Value = "" ActiveSheet.Cells(7, 2).Value = "" ActiveSheet.Cells(9, 2).Value = "" ActiveSheet.Cells(11, 2).Value = "" ActiveSheet.Cells(21, 2).Value = "" End If End Sub |
VBA 工数管理プログラム
前回のC#版を中止してから即席で作った。C#のときはMySQLだったが、今回はmdbファイルとした。使うのが1~2名であっても複数箇所で開く場合、データは別ファイルの方がいいだろうと判断。
今回は使う場面を想像できたので、あまりしっかり対策していないが、使う人が書式や関数を変更してしまっても大丈夫なように、起動時にしっかり設定し直す処理をいれれば、エクセルVBAでもDBのクライアントとしてかなり使えそう。
UserForm1
|
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 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 |
Function form_query() On Error GoTo try Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" rs.Open "select ID,customer,model,serial,quantity,notes from orders where serial = '" & UserForm1.TextBox1.Text & "';", cn Do Until rs.EOF UserForm1.TextBox8.Text = rs(0) UserForm1.TextBox2.Text = rs(1) UserForm1.TextBox3.Text = rs(2) UserForm1.TextBox1.Text = rs(3) UserForm1.TextBox7.Text = rs(4) UserForm1.TextBox4.Text = rs(5) rs.movenext Loop If UserForm1.TextBox8.Text <> "" Then UserForm1.TextBox5.Text = "1" UserForm1.TextBox6.Text = UserForm1.TextBox7.Text End If If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing form_query = True Exit Function try: If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox Err.Description form_query = False End Function Private Sub CommandButton1_Click() If UserForm1.TextBox1.Text = "" Then MsgBox "工番を入力してください。" Exit Sub End If If db_chk = False Then Exit Sub form_clear form_query End Sub Sub form_clear() UserForm1.TextBox8.Text = "" UserForm1.TextBox2.Text = "" UserForm1.TextBox3.Text = "" UserForm1.TextBox7.Text = "" UserForm1.TextBox4.Text = "" UserForm1.TextBox5.Text = "" UserForm1.TextBox6.Text = "" End Sub Function db_chk() On Error GoTo try Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" If cn.state = 1 Then cn.Close Set cn = Nothing db_chk = True Exit Function try: If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox "DBに接続できません。" db_chk = False End Function Function qty_parse() On Error GoTo try If UserForm1.TextBox5.Text = "" Or UserForm1.TextBox6.Text = "" Then MsgBox "対象枝を入力してください。" qty_parse = False Exit Function End If qty = CInt(UserForm1.TextBox7.Text) suffix_s = CInt(UserForm1.TextBox5.Text) suffix_e = CInt(UserForm1.TextBox6.Text) If suffix_s = 0 Or suffix_e = 0 Then MsgBox "対象枝は1以上の数字を指定する必要があります。" qty_parse = False Exit Function End If If suffix_e > qty Or suffix_s > suffix_e Then MsgBox "対象枝の指定範囲に問題があります。" qty_parse = False Exit Function End If qty_parse = True Exit Function try: MsgBox "対象枝が数字ではありません。" qty_parse = False End Function Private Sub CommandButton2_Click() Call MainWrite("1", "スタート", "作") End Sub Private Sub CommandButton3_Click() Call MainWrite("1", "スタート", "修") End Sub Private Sub CommandButton4_Click() Call MainWrite("3", "ストップ", "") End Sub Private Sub CommandButton5_Click() Call MainWrite("4", "完了", "") WorkTimeAdd End Sub Sub MainWrite(mark, state, typ) If ActiveSheet.Name <> "作業登録" Then MsgBox "作業登録で実施してください。" Exit Sub End If If UserForm1.TextBox8.Text = "" Then MsgBox "対象のIDが見つかりません。" Exit Sub End If If qty_parse = False Then Exit Sub Set w = Sheets("作業登録") serial = UserForm1.TextBox1.Text For suffix = CInt(UserForm1.TextBox5.Text) To CInt(UserForm1.TextBox6.Text) f = False For r = 2 To w.UsedRange.Rows.Count If serial = w.Cells(r, 1).Text And suffix = w.Cells(r, 2) Then f = True Call WriteCol(r, serial, suffix, mark, state, typ) End If Next r If f = False Then Call WriteCol(r, serial, suffix, mark, state, typ) End If Next suffix End Sub Sub WriteCol(r, serial, suffix, mark, state, typ) Set w = Sheets("作業登録") If w.Cells(r, 3).Value = "完了" Then MsgBox serial & "-" & suffix & "は既に完了しています。" Exit Sub End If Select Case mark Case "1" '作業スタート If w.Cells(r, 3).Value = "スタート" Then MsgBox serial & "-" & suffix & "は既にスタートしています。" Exit Sub End If If w.Cells(r, 3).Value = "" Or w.Cells(r, 3).Value = "ストップ" Then c = 8 End If Case "2" '修正スタート If w.Cells(r, 3).Value = "スタート" Then MsgBox serial & "-" & suffix & "は既にスタートしています。" Exit Sub End If If w.Cells(r, 3).Value = "" Or w.Cells(r, 3).Value = "ストップ" Then c = 8 End If Case "3" 'ストップ If w.Cells(r, 3).Value = "スタート" Then c = 9 End If If w.Cells(r, 3).Value = "" Or w.Cells(r, 3).Value = "ストップ" Then MsgBox serial & "-" & suffix & "はスタートしていません。" Exit Sub End If Case "4" '指定工番の完了 If w.Cells(r, 3).Value = "スタート" Then MsgBox serial & "-" & suffix & "はスタートしているため完了できません。" Exit Sub End If If w.Cells(r, 3).Value = "ストップ" Or w.Cells(r, 3).Value = "" Then w.Cells(r, 1).Value = serial w.Cells(r, 2).Value = suffix w.Cells(r, 3).Value = "完了" w.Cells(r, 3).Interior.ColorIndex = 0 Exit Sub End If End Select Do While True If w.Cells(r, c).Value = "" Then w.Cells(r, 1).Value = serial w.Cells(r, 2).Value = suffix w.Cells(r, 3).Value = state If (mark = 1 Or mark = 2) Then 'スタート w.Cells(r, 3).Interior.Color = RGB(255, 0, 0) w.Cells(r, 6).Value = "" w.Cells(r, c - 1).Value = typ End If If (mark = 3) Then 'ストップ w.Cells(r, 3).Interior.Color = RGB(255, 255, 0) w.Cells(r, 6).Value = c - 2 End If w.Cells(r, c).Value = Format(Now(), "yyyy/mm/dd hh:mm:00") Exit Do End If c = c + 3 Loop End Sub Private Sub CommandButton6_Click() UserForm1.TextBox1.Text = "" form_clear End Sub |
Module1
|
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 |
Sub auto_open() SetStyle If (StrConv(Sheets("設定").Range("B5").Value, 10) = "on") Then Sheets("作業登録").Activate UserForm1.Show End If On Error Resume Next Application.CommandBars("cell").Controls("フォーム表示").Delete Application.CommandBars("cell").Controls("フォーム表示").Delete With Application.CommandBars("cell").Controls.Add .Caption = "フォーム表示" .OnAction = "FormShow" End With End Sub Sub auto_close() On Error Resume Next Application.CommandBars("cell").Controls("フォーム表示").Delete Application.CommandBars("cell").Controls("フォーム表示").Delete End Sub Sub FormShow() Sheets("作業登録").Activate UserForm1.Show End Sub Sub SetStyle() Sheets("登録者").Cells(3, 2).NumberFormatLocal = "@" Sheets("登録者").Cells(5, 2).NumberFormatLocal = "@" Sheets("登録者").Cells(7, 2).NumberFormatLocal = "@" Sheets("登録者").Cells(11, 2).NumberFormatLocal = "@" Sheets("作業登録").Cells.NumberFormatLocal = "" Sheets("作業登録").Columns("A").NumberFormatLocal = "@" For c = 7 To 100 Step 3 Sheets("作業登録").Cells(1, c).Value = "種" Sheets("作業登録").Cells(1, c + 1).Value = "スタート" Sheets("作業登録").Cells(1, c + 2).Value = "ストップ" Sheets("作業登録").Columns(c).NumberFormatLocal = "" Sheets("作業登録").Columns(c + 1).NumberFormatLocal = "mm/dd hh:mm" Sheets("作業登録").Columns(c + 2).NumberFormatLocal = "mm/dd hh:mm" Sheets("作業登録").Columns(c).ColumnWidth = "2.5" Sheets("作業登録").Columns(c + 1).ColumnWidth = "12" Sheets("作業登録").Columns(c + 2).ColumnWidth = "12" Next c End Sub Sub WorkTimeAdd() Set w = Sheets("作業登録") For r = 2 To w.UsedRange.Rows.Count w.Cells(r, 4) = "" w.Cells(r, 5) = "" If w.Cells(r, 3).Text = "完了" And w.Cells(r, 6).Text <> "" Then n = 0 f = 0 For c = 7 To w.Cells(r, 6).Text Step 3 Select Case w.Cells(r, c).Text Case "作" n = n + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text) Case "修" f = f + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text) End Select Next c w.Cells(r, 4) = Int(n / 60) & "." & Format(n Mod 60, "00") & " H" w.Cells(r, 5) = Int(f / 60) & "." & Format(f Mod 60, "00") & " H" End If Next r w.Activate End Sub Function WorkTime(date_s, date_e) On Error GoTo try date_s = CDate(date_s) date_e = CDate(date_e) ts = 0 Do While date_s < date_e ts = ts + 1 If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:00:00") And _ date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:15:00") Then ts = ts - 1 End If If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:00:00") And _ date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:50:00") Then ts = ts - 1 End If If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:00:00") And _ date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:15:00") Then ts = ts - 1 End If If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:20:00") And _ date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:30:00") Then ts = ts - 1 End If date_s = DateAdd("n", 1, date_s) Loop WorkTime = ts Exit Function try: WorkTime = 0 End Function |
Sheet1(登録者)
|
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 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
Function BuildQuery(mark) q_i = Sheets("登録者").Range("B21").Value q_c = Sheets("登録者").Range("B3").Value q_m = Sheets("登録者").Range("B5").Value q_s = Sheets("登録者").Range("B7").Value q_q = Sheets("登録者").Range("B9").Value q_n = Sheets("登録者").Range("B11").Value q_i = StrConv(q_i, vbNarrow) q_s = StrConv(q_s, vbNarrow) q_q = StrConv(q_q, vbNarrow) q_i = Replace(q_i, "'", "’") q_c = Replace(q_c, "'", "’") q_m = Replace(q_m, "'", "’") q_s = Replace(q_s, "'", "’") q_q = Replace(q_q, "'", "’") q_n = Replace(q_n, "'", "’") q_i = Replace(q_i, """", "’") q_c = Replace(q_c, """", "’") q_m = Replace(q_m, """", "’") q_s = Replace(q_s, """", "’") q_q = Replace(q_q, """", "’") q_n = Replace(q_n, """", "’") If mark = "s1" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'true'" If mark = "s2" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'false'" If mark = "i" Then q = "insert into orders (customer,model,serial,quantity,notes,visible) values ('" & q_c & "','" & q_m & "','" & q_s & "'," & q_q & ",'" & q_n & "','true');" If mark = "u" Then q = "update orders set customer = '" & q_c & "', model = '" & q_m & "', serial = '" & q_s & "', quantity = " & q_q & ", notes = '" & q_n & "' where ID = " & q_i & ";" If mark = "d" Then q = "delete from orders where ID = " & q_i & ";" If mark = "h" Then q = "update orders set visible = 'false' where ID = " & q_i & ";" BuildQuery = q: Debug.Print q End Function Private Sub CommandButton6_Click() If db_chk = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Private Sub CommandButton5_Click() If db_chk = False Then Exit Sub grid_clear If grid_load("s2") = False Then Exit Sub form_clear End Sub Private Sub CommandButton1_Click() If db_chk = False Then Exit Sub If form_chk = False Then Exit Sub If qty_parse = False Then Exit Sub If form_query("i") = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Private Sub CommandButton2_Click() If db_chk = False Then Exit Sub If id_chk = False Then Exit Sub If form_chk = False Then Exit Sub If qty_parse = False Then Exit Sub If form_query("u") = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Private Sub CommandButton3_Click() If db_chk = False Then Exit Sub If id_chk = False Then Exit Sub yn = MsgBox("削除しますか？", vbYesNo) If yn = vbNo Then Exit Sub If form_query("d") = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Private Sub CommandButton4_Click() If db_chk = False Then Exit Sub If id_chk = False Then Exit Sub If form_query("h") = False Then Exit Sub grid_clear If grid_load("s1") = False Then Exit Sub form_clear End Sub Function id_chk() On Error GoTo try If Sheets("登録者").Range("B21").Value = "" Then GoTo try v = CLng(Sheets("登録者").Range("B21").Value) id_chk = True Exit Function try: MsgBox "IDが正しくありません。" id_chk = False End Function Function form_chk() If Sheets("登録者").Range("B3").Value = "" Then GoTo try If Sheets("登録者").Range("B5").Value = "" Then GoTo try If Sheets("登録者").Range("B7").Value = "" Then GoTo try If Sheets("登録者").Range("B9").Value = "" Then GoTo try form_chk = True Exit Function try: MsgBox "入力が不足しています。" form_chk = False End Function Sub grid_clear() Sheets("登録者").Range("G4:L1000").Delete End Sub Sub form_clear() Sheets("登録者").Range("B3").Value = "" Sheets("登録者").Range("B5").Value = "" Sheets("登録者").Range("B7").Value = "" Sheets("登録者").Range("B9").Value = "" Sheets("登録者").Range("B11").Value = "" Sheets("登録者").Range("B21").Value = "" End Sub Function qty_parse() On Error GoTo try qty = CLng(Sheets("登録者").Range("B9").Value) If qty = 0 Then GoTo try qty_parse = True Exit Function try: MsgBox "数量が正しくありません。" qty_parse = False End Function Function form_query(mark) On Error GoTo try Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" cn.Execute BuildQuery(mark) If cn.state = 1 Then cn.Close Set cn = Nothing form_query = True Exit Function try: If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox Err.Description form_query = False End Function Function grid_load(mark) On Error GoTo try Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" rs.Open BuildQuery(mark), cn r = 4 Do Until rs.EOF Sheets("登録者").Cells(r, 7).Value = rs(0) Sheets("登録者").Cells(r, 8).Value = rs(1) Sheets("登録者").Cells(r, 9).Value = rs(2) Sheets("登録者").Cells(r, 10).Value = rs(3) Sheets("登録者").Cells(r, 11).Value = rs(4) Sheets("登録者").Cells(r, 12).Value = rs(5) Sheets("登録者").Range("G" & r & ":L" & r & "").Borders.LineStyle = True r = r + 1 rs.movenext Loop If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing grid_load = True Exit Function try: If rs.state = 1 Then rs.Close Set rs = Nothing If cn.state = 1 Then cn.Close Set cn = Nothing grid_load = False End Function Function db_chk() On Error GoTo try Set cn = CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";" If cn.state = 1 Then cn.Close Set cn = Nothing db_chk = True Exit Function try: If cn.state = 1 Then cn.Close Set cn = Nothing MsgBox "DBに接続できません。" db_chk = False End Function Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row >= 4 And Target.Column = 7 And Target.Text <> "" Then ActiveSheet.Cells(3, 2).Value = ActiveSheet.Cells(Target.Row, 8).Value ActiveSheet.Cells(5, 2).Value = ActiveSheet.Cells(Target.Row, 9).Value ActiveSheet.Cells(7, 2).Value = ActiveSheet.Cells(Target.Row, 10).Value ActiveSheet.Cells(9, 2).Value = ActiveSheet.Cells(Target.Row, 11).Value ActiveSheet.Cells(11, 2).Value = ActiveSheet.Cells(Target.Row, 12).Value ActiveSheet.Cells(21, 2).Value = ActiveSheet.Cells(Target.Row, 7).Value ElseIf Target.Row >= 4 And Target.Column = 7 And Target.Text = "" Then ActiveSheet.Cells(3, 2).Value = "" ActiveSheet.Cells(5, 2).Value = "" ActiveSheet.Cells(7, 2).Value = "" ActiveSheet.Cells(9, 2).Value = "" ActiveSheet.Cells(11, 2).Value = "" ActiveSheet.Cells(21, 2).Value = "" End If End Sub |
Sheet3(作業登録)
|
1 2 3 4 5 6 7 8 |
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If UserForm1.Visible And UserForm1.TextBox8.Text = "" And _ Target.Row >= 2 And Target.Column = 1 And Target.Text <> "" Then UserForm1.TextBox1.Text = Target.Text End If End Sub |
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 |
Sub SetStyle() Sheets("集計").Rows("2:1000").Delete Sheets("必要数").Range("F2:F18").Value = "" Sheets("必要数").Range("H2:H18").Value = "" Sheets("必要数").Range("J2:J18").Value = "" Sheets("必要数").Range("L2:L18").Value = "" End Sub Private Sub CommandButton1_Click() yn = MsgBox("集計シートはクリアされます。よろしいですか？", vbYesNo) If yn = vbNo Then Exit Sub Call SetStyle Set w = Sheets("リスト") r = 2 Do While w.Cells(r, 2).Value <> "" modelName = w.Cells(r, 2).Value qty = w.Cells(r, 4).Value Call RowsCopy(modelName, qty) r = r + 1 Loop Call MakeSummary Sheets("集計").Cells(1, 1).CurrentRegion.Borders.LineStyle = True Sheets("必要数").Activate End Sub Sub RowsCopy(modelName, qty) Set w = Sheets("部品") destRow = Sheets("集計").UsedRange.Rows.Count + 1 r = 2 Do While w.Cells(r, 1).Value <> "" If w.Cells(r, 1).Value = modelName Then w.Range("A" & r & ":G" & r & "").Copy Sheets("集計").Range("A" & destRow & ":G" & destRow & "") Sheets("集計").Range("G" & destRow & "").Value = Sheets("集計").Range("G" & destRow & "") * qty Sheets("集計").Range("H" & destRow & "").Value = "=E" & destRow & "*F" & destRow & "*G" & destRow & "" destRow = destRow + 1 End If r = r + 1 Loop End Sub Sub MakeSummary() Set w = Sheets("必要数") lastRow = Sheets("集計").UsedRange.Rows.Count For r = 2 To 18 w.Cells(r, 3).Value = "=SUMIFS(集計!H2:H" & lastRow & ",集計!C2:C" & lastRow & ",A" & r & ",集計!D2:D" & lastRow & ",B" & r & ")" w.Cells(r, 4).Value = "=SUMIFS(集計!G2:G" & lastRow & ",集計!C2:C" & lastRow & ",A" & r & ",集計!D2:D" & lastRow & ",B" & r & ")" Next r End Sub |
VBA 外注管理用工程チャート作成機能
列数が多くなると管理しづらくなるので、マクロから列幅をコントロールできるようにすること。
一覧表の形式からチャート形式を作成できるようした。
UserForm1
|
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 |
Private Sub CommandButton1_Click() Application.DisplayAlerts = False If UserForm1.ComboBox1.Value = "" Or UserForm1.ComboBox2.Value = "" Then Exit Sub If UserForm1.ComboBox5.Value = "" Or UserForm1.ComboBox5.Value = "全て出力" Then suppKey = "全て出力" Else suppKey = UserForm1.ComboBox5.Text End If f = UserForm1.ComboBox1.Value & "/" & UserForm1.ComboBox2.Value & "/1" t = UserForm1.ComboBox3.Value & "/" & UserForm1.ComboBox4.Value & "/1" If IsDate(f) = False Or IsDate(t) = False Then Exit Sub If CDate(f) > CDate(t) Then Exit Sub For Each w In Sheets If w.Name = "工程" Then yn = MsgBox("工程シートが存在します。削除して続行しますか？", vbYesNo) If yn = vbNo Then Exit Sub Next w If yn = vbYes Then Sheets("工程").Delete Set w = Sheets.Add w.Name = "工程" Application.DisplayAlerts = True Call CreateProcessChart(UserForm1.ComboBox1.Value, UserForm1.ComboBox2.Value, UserForm1.ComboBox3.Value, UserForm1.ComboBox4.Value, suppKey) Unload UserForm1 End Sub Private Sub UserForm_Initialize() UserForm1.ComboBox1.AddItem Year(Now) UserForm1.ComboBox1.AddItem Year(DateAdd("yyyy", 1, Now)) UserForm1.ComboBox1.AddItem Year(DateAdd("yyyy", 2, Now)) UserForm1.ComboBox3.AddItem Year(Now) UserForm1.ComboBox3.AddItem Year(DateAdd("yyyy", 1, Now)) UserForm1.ComboBox3.AddItem Year(DateAdd("yyyy", 2, Now)) For m = 1 To 12 UserForm1.ComboBox2.AddItem m UserForm1.ComboBox4.AddItem m Next m UserForm1.ComboBox1.Text = Year(Now) UserForm1.ComboBox2.Text = Month(Now) UserForm1.ComboBox3.Text = Year(Now) UserForm1.ComboBox4.Text = Month(Now) 'UserForm1.ComboBox3.Text = Year(DateAdd("m", 3, Now)) 'UserForm1.ComboBox4.Text = Month(DateAdd("m", 3, Now)) Dim dic: Set dic = CreateObject("Scripting.Dictionary") For r = 6 To Sheets("入力").UsedRange.Rows.Count If Not dic.Exists(Sheets("入力").Cells(r, 4).Value) Then dic.Add Sheets("入力").Cells(r, 4).Value, "" Next r If Not dic.Exists("全て出力") Then dic.Add "全て出力", "" Keys = dic.Keys For i = 0 To dic.Count - 1 UserForm1.ComboBox5.AddItem Keys(i) Next i Set dic = Nothing UserForm1.ComboBox5.Text = "全て出力" End Sub |
Module2
|
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 |
Sub RestContext() On Error Resume Next Application.CommandBars("cell").Controls("列幅").Delete Application.CommandBars("cell").Controls("列幅").Delete Application.CommandBars("cell").Controls("工程フォーム表示").Delete Application.CommandBars("cell").Controls("工程フォーム表示").Delete End Sub Sub SetContext() With Application.CommandBars("cell").Controls.Add(Type:=msoControlPopup) .Caption = "列幅" With .Controls.Add(Type:=msoControlButton) ' (Type:=msoControlButton)はなくてもOK .Caption = "列幅取得" .OnAction = "getColsWidth" End With With .Controls.Add .Caption = "列幅指定(1)" .OnAction = "'setCols(2)'" '引数を渡すなら ' が必要。あるいは、ActionControl.Captionにて End With With .Controls.Add .Caption = "列幅指定(2)" .OnAction = "'setCols(3)'" End With With .Controls.Add .Caption = "列幅指定(3)" .OnAction = "'setCols(4)'" End With End With With Application.CommandBars("cell").Controls.Add .Caption = "工程フォーム表示" .OnAction = "UserFormShow" End With End Sub Sub setCols(k As Integer) For i = 3 To 51 If Sheets("設定").Cells(i, k).Value = "" Then MsgBox "設定に不正があります。" Exit Sub End If Next Sheets("入力").Activate For i = 3 To 51 Sheets("入力").Columns(i - 2).ColumnWidth = Sheets("設定").Cells(i, k).Value Next End Sub Sub getColsWidth() Sheets("設定").Activate Sheets("設定").Range("E3:E51").Value = "" For i = 3 To 51 Sheets("設定").Cells(i, 5).Value = Sheets("入力").Columns(i - 2).ColumnWidth Next End Sub |
Module3
|
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 |
Sub UserFormShow() UserForm1.Show End Sub Sub CreateProcessChart(y, m, yy, mm, suppKey) Sheets("工程").Cells(1, 1).Value = "製作先" Sheets("工程").Cells(1, 2).Value = "工番" Sheets("工程").Cells(1, 3).Value = "型式" Sheets("工程").Cells(1, 4).Value = "数量" Sheets("工程").Cells(1, 5).Value = "客先" ymd = DateAdd("m", -1, CDate(y & "/" & m & "/21")) ymdymd = CDate(yy & "/" & mm & "/20") c = 6 Do While CDate(ymd) <= CDate(ymdymd) Sheets("工程").Cells(1, c).Value = ymd ymd = DateAdd("d", 1, ymd) c = c + 1 Loop i = 2 For r = 6 To Sheets("入力").UsedRange.Rows.Count flg = True If suppKey <> "全て出力" And suppKey <> Sheets("入力").Range("D" & r).Value Then flg = False If Sheets("入力").Range("AK" & r).Value = "有" And flg = True Then Sheets("工程").Range("A" & i).Value = Sheets("入力").Range("D" & r).Value Sheets("工程").Range("B" & i).Value = Sheets("入力").Range("H" & r).Value Sheets("工程").Range("C" & i).Value = Sheets("入力").Range("J" & r).Value Sheets("工程").Range("D" & i).Value = Sheets("入力").Range("M" & r).Value Sheets("工程").Range("E" & i).Value = Sheets("入力").Range("N" & r).Value rangeAddress = Split("E,F,R,T,U", ",") chartText = Split("完成期日,本納期,出図日,製缶検査,完成検査", ",") ChartColor = Split("&HCC99FF,&HCC99FF,&H99CCFF,&H99CCFF,&H99CCFF", ",") For a = 0 To 4 If IsDate(Sheets("入力").Range(rangeAddress(a) & r).Value) = True Then c = 6 Do While Sheets("工程").Cells(1, c).Value <> "" If CDate(Sheets("工程").Cells(1, c).Value) = CDate(Sheets("入力").Range(rangeAddress(a) & r).Value) Then Sheets("工程").Cells(i, c).Value = chartText(a) Sheets("工程").Cells(i, c).Interior.Color = ChartColor(a) End If c = c + 1 Loop End If Next a fromRangeAddress = Split("AM,AP,AS,AV", ",") toRangeAddress = Split("AN,AQ,AT,AW", ",") chartTextAddress = Split("AL,AO,AR,AU", ",") ChartColor = Split("&H663399,&HFF6633,&H00CC99,&H00CCFF", ",") For a = 0 To 3 fromDate = Sheets("入力").Range(fromRangeAddress(a) & r).Value toDate = Sheets("入力").Range(toRangeAddress(a) & r).Value chartText = Sheets("入力").Range(chartTextAddress(a) & r).Value textFlag = False If IsDate(fromDate) = True Then If IsDate(toDate) = False Then toDate = fromDate c = 6 Do While Sheets("工程").Cells(1, c).Value <> "" If CDate(Sheets("工程").Cells(1, c).Value) >= CDate(fromDate) And _ CDate(Sheets("工程").Cells(1, c).Value) <= CDate(toDate) Then If textFlag = False Then Sheets("工程").Cells(i, c).Value = Sheets("工程").Cells(i, c).Value & " " & chartText textFlag = True End If Sheets("工程").Cells(i, c).Interior.Color = ChartColor(a) End If c = c + 1 Loop End If Next a i = i + 1 End If Next r Sheets("工程").Rows(1).NumberFormatLocal = "dd" Sheets("工程").Rows(1).ShrinkToFit = True Sheets("工程").Rows(1).HorizontalAlignment = xlCenter Sheets("工程").Columns.AutoFit c = 6 Do While Sheets("工程").Cells(1, c).Value <> "" Sheets("工程").Columns(c).ColumnWidth = 3.4 If c = 6 Or Day(Sheets("工程").Cells(1, c).Value) = 1 Then Sheets("工程").Cells(1, c).NumberFormatLocal = "mm/dd" End If If Weekday(Sheets("工程").Cells(1, c).Value) = 1 Then Sheets("工程").Cells(1, c).Font.Color = RGB(255, 0, 0) c = c + 1 Loop Sheets("工程").UsedRange.Borders.LineStyle = True Sheets("工程").Cells(2, 1).Select ActiveWindow.FreezePanes = True End Sub |
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 |
Private Sub CommandButton1_Click() For i = Selection(1).Row To Selection(Selection.Count).Row '選択範囲の行でループ For ii = 8 To 100 If Cells(i, ii).Interior.Color = RGB(0, 0, 0) Then If ii - UserForm1.TextBox1.Value < 8 Then Exit For Cells(i, ii).Interior.ColorIndex = xlNone Cells(i, ii - UserForm1.TextBox1.Value).Interior.Color = RGB(0, 0, 0) End If If Cells(i, ii).Interior.Pattern = 15 Then If ii - UserForm1.TextBox1.Value < 8 Then Exit For Cells(i, ii).Interior.Pattern = xlPatternNone Cells(i, ii - UserForm1.TextBox1.Value).Interior.Pattern = 15 End If Next ii Next i End Sub Private Sub CommandButton2_Click() For i = Selection(1).Row To Selection(Selection.Count).Row '選択範囲の行でループ For ii = 100 To 8 Step -1 If Cells(i, ii).Interior.Color = RGB(0, 0, 0) Then If ii + UserForm1.TextBox1.Value > 100 Then Exit For Cells(i, ii).Interior.ColorIndex = xlNone Cells(i, ii + UserForm1.TextBox1.Value).Interior.Color = RGB(0, 0, 0) End If If Cells(i, ii).Interior.Pattern = 15 Then If ii + UserForm1.TextBox1.Value > 100 Then Exit For Cells(i, ii).Interior.Pattern = xlPatternNone Cells(i, ii + UserForm1.TextBox1.Value).Interior.Pattern = 15 End If Next ii Next i End Sub |