掲載ファイルは、プログラムでEドライブから開きますから
どのファイルも、Eドライブに左側の名前で保存してください。
[工数の入力と抽出.xlsm]は、Exselではkosu.xlsmに
[工数集計データベース.xlsm]は、kosu-dbになっています。
プログラムを変更すれば、他のドライブに保存可能です。
掲載参考 EXCEL ファイルダウンロード
1. kosu.xlsm
2. kosu-db.xlsm
自動でOption Explicitを入れるには、
VBAの[ツール]に[オプション]があります。
[変数の宣言を強制する]にチェックを付ける。
宣言とは、Dimで定義することです。
Option Explicitを定義しない場合、変数をDimで
宣言しなくてもエラーにはなりません。
その代わり、同じ変数名を複数使用する可能性が
発生しますので、わかりづらくなります。
※ Option Explicit は変数を必ず宣言するという命令です。Dim で変数を宣言しないとエラーに
なります。
[F] ボタンを押すと、上側のボタンが表示と非表示を切り替える。
[C] ボタンを押すと、下側のボタンが表示と非表示を切り替える。
Sub F ボタンの表示非表示( )
If ActiveSheet.Shapes("呼出 M").Visible=False Then ' 非表示なら
ActiveSheet.Shapes("呼出 M").Visible=True ' 表示する。
Else ' 表示していたら、
ActiveSheet.Shapes("呼出 M").Visible=False ' 非表示にする。
End If
End Sub
Sub C ボタンの表示非表示( )
If ActiveSheet.Shapes("行番 ON").Visible=False Then ' 非表示なら
ActiveSheet.Shapes("行番 ON").Visible=True ' 表示する。
Else ' 表示していたら、
ActiveSheet.Shapes("行番 ON").Visible=False ' 非表示にする。
End If
End Sub
※オートシェイプの表示と非表示は、Visible の True と False で行う。
[データを呼出]を押すと Private Sub CommandButton1 _ Click を実行する。
Sub 新規作成( )
Sheets("menu").Range("B8:R8").ClearContents
新規登録.Show vbModeless ' vbModeless はフォームが表示されていてもカーソルで
End Sub ' 他のシートを参照することができる。
このボタンを押すと、[新規作成]マクロを実行する。
Set myRange=Nothing ' Setを使えば、必ずこの Nothing をする必要がある。
Set myRange=Worksheets("DT").Range("B5:B" & intRowE).Find(strSeib)
' B5からB列のデータ最下行まで、strSeibを検索して、有ればmyRangeに代入する。
If myRange Is Nothing Then ' myRangeがデータ無しなら、
intRow=intRow+1 ' intRowはデータ最下行の一つ下を代入する。
Else
intRow=myRange.Row ' myRangeにデータが有れば、その行番を代入する。
End If
※Find検索で、すでに製番があればその行に工程を追加し、無ければデータ最下行の一つ下に
新規の製番を記入する。
Workbooks.Open Filename:="E:\ 工数集計データベース.xlsm"
' [Call ファイルが他の使用の為待機]を使用するときは、この構文は不要になる。
Call ファイルが他の使用の為待機
' このサブマクロは、ネットワークなどで、[工数集計データベース.xlsm]を複数のPCから
' アクセスして使用する場合には、開くときに他のPCと競合する。その時に使用するもので
' 他が開いたときには読み取り専用Bookになる。それを利用したもので、読み取り専用になると
' それが解除されるまで待機する。3秒おきに読み取り専用かどうかを自動で確認する。
With ActiveWorkbook ' 開いたファイルが、
strF=.ReadOnly ' 読み取り専用なら、strF に True を代入する。
If strF=True Then ' strF が True なら False になるまで Loop する。
PauseTime=3 ' 3秒
myAns=MsgBox("本当に登録しますか？",vbYesNo) 'メッセージボックスにYes Noボタンが装備される。
If myAns=vbNo Then ' No ボタンが押されたら、マクロを終了する。
Exit Sub
End If
If Sheets("DT").Range("B5") <> " "
Then ' DTのB5が空白でなかったら、
intRowE=Sheets("DT").Range("B4").End(xlDown).Row ' データの最下行番号をintRowEに代入する。
Else
intRowE=4 ' DTのB5が空白なら、intRowEに4を代入する。
End If
登録は、今入力した時間データをDTシートに記入する事と、"E:\工数集計データベース.xlsm" に追記する。
このボタンを押すと実行される。
Private Sub 取消_Click( )
Application.ScreenUpdating=False ' マクロの実行時に画面を動かさない。
Call 戻す ' [戻す]マクロを実行する。
Application.ScreenUpdating=True ' マクロの実行時に画面を動かす。
End Sub
Tot=Val(Range("Q8")) ' Q8 セルの値は文字列になっているので、計算できるように、数値に Val
( )で
' 変換している。
KT=H+Tot
この時間の入力方法は、1時間を 1 、10分を 0.1 、15分を 0.15 と入力する。
だから、作業を始めるときに時計を見て、終わったときに時計を見ると、何時間何分経過したのかが分かるので、
そのまま集計用紙に記入すればよい。
3時間15分なら、3.15 と書けば楽である。だからここでも、そのように時間を合計する。
設計工数が 31.30 31時間30分
電気設計が 20.50 20時間50分 を合計する場合、
T=Int (KT) ' KT が 31.30 なら Int は整数値を求めるので、T=31 となる。
S=Round (KT −T, 2) ' 31.30−31 の小数点以下2文字を求めて S=0.30 になる。
i=2 ' 設計工数と電気設計工数の合計は、
KT=H+Tot は 51.8=20.5+31.3 ' KT が 51.8 になる。
T=Int(KT) ' T は 51
S=Round(KT−T,2) ' S は 0.8 になる。
If S >= 0.6 Then K=1 ' S が 0.6 より大きいか、イコールの場合 K=1 になるので
K=1
If K=1 Then ' K が 1 の場合
Total=T+S+K−0.6 ' Total=51+0.8+1−0.6 で52.2 になる。
Else
Total=T+S ' K=0 の場合
End If
TH=Int(Total) ' TH=Int(52.2) で TH は 52 になる。
M1=Round(Total−TH, 2) ' M1=Round(52.2−52, 2) で M1 は 0.2 になる。
M2=Mid(M1,3,2) ' M2=Mid(0.2, 3, 2) で0.2 の左から 3 文字目から二文字を取り出すと
' M2 は 2 になる。
M3=Len(M1) ' M1 は 0.2 だから、その文字数は 3 文字で M3 は 3 になる。
' Len( ) は文字数を数える関数である。
If M3=1 Then M="00"
If M3=3 Then M=M2 & "0" ' M3 は 3 だから、M2 は 2 で 0 を付けると M
は 20 になる。
If M3=4 Then M=M2
Range("Q8") = TH & "." & M ' TH は 52 で M は
20 だから、Q8セルに 52.20 と書かれることになる。
Call 戻す用転記 ' [Sub 戻す用転記( )]が実行される。
※これは、[転記]ボタンを押した時に、間違えて加算した場合に戻すために、[戻す]シートに書いて
置くものである。
' '
If Se1 <> enpty Then 入力.TextBox2.Text = Se1 ' enpty は空白のことです。Se1
が空白でなかったら、
' 入力.TextBox2.Text にSe1 を書く。
Call 合計表示
Flag は TextBox11 に記入してあり、判定用の変数で、作業者に見える必要が無いので文字は背景色と同色に
してある。フォーム内で、複数のマクロを使用する場合は、変数を定義しても、その値を別のマクロに受け渡す
事はできない。だから、フォームに書いた値を Flag として別のマクロに渡している。マクロとしては別の方法も
あるが、それはまた別の機会に説明します。
[転送マクロ]
If TextBox2 <> " " Then ' 転送の時に、設計に値が入っていると（空白でないと）
TextBox11.Value=2 ' TextBox11 に 2 を記入する。
[加算マクロ]
If Flag=2 Then ' Flag が 2 なら G8 の値に TextBox2 の値を加算する。
Tot=Sheets("menu").Range("G8")+Val(入力.TextBox2) '
それを Tot に代入する。
End If
If Flag=3 Then
Tot=Sheets("menu").Range("H8")+Val(入力.TextBox3)
End If
T=Int(Tot) ' Tot は加算された値で、62.6 の場合は整数値の 62 が T に入る。
S=Round(Tot−T, 2) ' 62.6−62 は 0.6 で小数点以下二桁だが一桁しかないので S に 0.6 が入る。
If S >=0.6 Then K=1 ' S が 0.6 と同じか、0.6 より大きい場合は K=1 になる。
If S < 0.6 Then K=0 ' S が 0.6 以下なら K=0 になる。（これは、0.6 が1時間のことだから。）
If K=1 Then ' ここで K は 1 だから1時間繰り上がることになり
Total=T+S+K−0.6 ' 1時間繰り上がった場合は、0.6 を差し引いている。
Else
Total= T+S ' K=0 の場合は繰り上がりが無いので、整数値と小数値を加算している。
End If
If Flag=2 Then
Sheets("menu").Range("G8").Value=Total ' Flag=2
なら設計に記入する。
End If
Call 入力表示記入 ' [入力表示記入]マクロを実行する。
Flag=TextBox11
If myAns=vbYes Then ' Yesボタンを押していたら、
Call 加算
Else ' Yesボタンを押していなかったら、
Sheets("menu").Range("P8").Value=Val(TextBox12) '
合計値を P8 に記入する。
End If ' Val はTextBox12の数字文字を計算のできる数値に変換する。
T2= Round(Val(TextBox2.Text),2) ' TextBox2の値の小数点以下2桁をT2に代入する。
If myAns=vbYes Then ' メッセージボックスのYes No ボタンのどちらを押したのかを
' 判定するためのもので、vbYesの値は 6 で、vbNoの値は 7 である。
' だから、Yesボタンを押すと myAns に 6 が入り、Noを押すと 7 が入る。
※ myAns=vbYes の場合、Yes ボタンを押すと、myAns は 6 で、vbYes は 6 となる。
No ボタンを押すと、myAns は 7 で、vbYes は 6 となるから、イコールではない。
MsgBox関数の戻り値
このボタンを押すと、Private Sub CB2_Click( ) を実行して、menuシートの[設計]工数に
値が転記される。
If 自動計算.Se= True Then ' [設計]にチェックが付いていたら、
If 入力.TextBox2<> " " Then ' 入力フォームの[設計]に数値が入っていたら、
myAns= MsgBox("データが入っていますよ" & vbCrLf & vbCrLf &
"「OK」なら入力値に置き換え" & _
vbCrLf & vbCrLf & "「キャンセル」なら中止します。" , vbOKCancel)
' vbOKCancel は [OK]と[キャンセル]ボタンを装備する。
If myAns=vbOK Then ' [OK]ボタンを押したら
入力.TextBox2.Value=自動計算.TBkei ' 入力の[設計]に数値を書く。
Else
Exit Sub ' [キャンセル]ボタンを押したら終了する。
End If
Else
入力.TextBox2.Value=自動計算.TBkei ' 入力フォームの[設計]に数値が入っていなかったら、
End If ' 数値を書く。
End Sub
If 自動計算.Se= False And 自動計算.Dn= False And 自動計算.Ku= False And 自動計算.Cy= False
And _
自動計算.Mc= False And 自動計算.An= False And 自動計算.He= False And 自動計算.Jb= False
And _
自動計算.En= False And 自動計算.Ke= False Then
' どのラジオボタンにもチェックが付いていなかったら
MsgBox "工程にチェックが無い" ' メッセージボックスを表示する。
Exit Sub ' マクロを終了し、入力を待つ。
End If
※二つのフォームを開いている時には、どちらか判別できないのでフォーム名が必要です。
If 自動計算.TextBox48 <> " " Then ' 自動計算.TextBox48 は合計である。
' ここで「自動計算. 」と記入するのは、[入力]と[自動計算]の二つのフォームを
' 開いているので、変数の識別ができるように、フォーム名を入れている。
TBkei = TextBox48 ' TextBox48が空白でなかったら、TBkei に代入する。
End If
続けて入力するとその合計値が入るので、終わりなら工程にチェックを入れて、[合計を製番データに記入]
ボタンを押せば、Private Sub 入力に転送_Click( ) を実行し、[工程入力]フォームが開いて設計に工数が入る。
テキストボックスに工数を入力すると即座に合計ボックスに合計が入る。
テキストボックスに左から順に工数を入力して行く。
このボタンを押すと、Private Sub YB1_Click( ) が実行される。
自動計算.Show
End Sub
入力.Show で[入力]フォームが表示される。
Private Sub CB1_Click( )
If Range("A8")=2 Then ' [セル選択]を押した時に、A8 に 2 が入っていると、
GN=ActiveCell.Row ' 選択したセルの行番号を検索して GN に代入する。
intRow=Sheets("menu").Range("B7").End(xlDown).Row '
最下行番号を調べる。
For i=8 To intRow ' GN行以外の行を消去する処理
If i=GN Then ' 今見ている 8 行目が GN なら、
Range("B9:Q" & intRow).ClearContents ' 9行目以下を消去する。
GoTo Jump ' 抽出終了だから、最終処理へジャンプする。
End If
If i<> GN Then ' i が GN でなかったら、
Rows("8:8").Delete Shift:=xlUp ' 8 行目を削除して上に詰める。
End If
Next
Unload 呼出表示
入力.Show
End If
If Range("A8")=1 Then ' 1 行しかないので消去行がない。
Unload 呼出表示 ' 呼出表示フォームを非表示にする。
入力.Show ' 入力フォームを表示する。
End If
Range("A8").Value=" " ' A8を空白にする。
If 呼出表示.TextBox1.Text <> " " Then ' 呼出表示フォームのTextBox1が空白でなかったら。
intRow=Sheets("menu").Range("B7").End(xlDown).Row
For i=8 To intRow
If Range("B8")=呼出表示.TextBox1.Text Then
Range("B9:Q" & 20).ClearContents
GoTo Jump
End If
If Range("B8") <> 呼出表示.TextBox1.Text Then
Rows("8:8").Delete Shift:=xlUp
Else
Range("B9:Q" & intRow).ClearContents
End If
Next
End If
Jump:
Call 呼出表示記入
Range("A8").Value=1
Unload 呼出表示
入力.Show
End Sub
このボタンを押すと、Private Sub CB1_Click( ) が実行される。
Private Sub DB_Click( )
If Range("B9") <> " " Then Range("A8").Value=2 '
B9が空白でなかったら、B8にデータが有る
End Sub ' と言うことで、その時にA8に 2 が入る。
このボタンを押すと、Private Sub DB_Click( ) が実行される。
A-3553 が選択された状態で、[工数入力]フォームが開く。
複数の製番が抽出された場合で、その中の A-3553 を選択したい場合は、カーソルで選択して、[セル選択]
ボタンを押し[入力]ボタンを押すと A-3553 だけが選択される。
JumpNext2:
Loop
GoTo JumpEnd
JumpERR:
Sheets("menu").Select
MsgBox "この製番データは、有りません" ' メッセージボックスを表示する。
Unload 抽出 ' 抽出フォームを非表示にする。
Exit Sub ' プログラムの終了
JumpERR2:
Sheets("menu").Select
If Range("B8")=" " True
MsgBox "この製番データは、有りません"
End If
Unload 抽出
Exit Sub
JumpEnd:
Set myRange=Nothing ' Set 変数の myRange を終了させる。
Sheets("menu").Select
Application.ScreenUpdating=True
Unload 抽出
Call 合計表示 ' 合計表示マクロを起動する。
呼出表示.Show vbModeless ' 呼出表示フォームを表示させる。
Range("B5").Select ' vbModoless を書くとフォームが表示されている時でも
End Sub ' カーソルを他のシートに移動できる。
Jump2
If TextBox2.Text=" " Then GoTO Jump3 ' 品名検索に入力がないと、Jump3 へ進む
N=7
strNon=TextBox2.Text ' 品名検索で入力品名をstrNonに代入する。
intRow=5
Sheets("DT").Select
intRowE=Sheets("DT").Range("E5").End(xlDown).Row '
シートDTのデータ最下行番号
Rn=0
Do ' 抽出される品名が複数ある場合には、Do から Loop を繰り返し抽出する。
Sheets("DT").Select
If intRow >=intRowE Then GoTo JumpEnd ' intRow と intRowE が同じか、intRow
が
' intRowE より大きい時は終了処理へジャンプする。
Set myRange=Worksheets("DT").Range("E" & intRow
& ":" & "E" &intRowE) _
.Find(What:=strNon,lookat:=xlWhole)
' Findの完全一致検索の構文である。 似たような品名がある場合に、入力文字列と同じものしか検出されない。
If myRange Is Nothing Then GoTo JumpERR2 ' 抽出がない場合には、JumpERR2 へジャンプする。
intRow=myRange Row ' 複数抽出で、抽出が終わりの時に、Doを終わるために
' 抽出毎にその行番をintRowに入れる。
If intC=myRange.Row Then GoTo JumpEnd ' 今回の抽出行番と前回の抽出行番号が同じなら抽出完了
' なので終了処理へジャンプする。(これは最終行の場合)
intC=intRow ' 次回の終了判定のために、抽出の行番をintCに代入する。
Range("B" & intRow & ":P " & intRow).Copy
Rn=Rn + 1 ' menuの書き込み位置を下にずらすために使用する。
Sheets("menu").Select
Range("B" & N + Rn).Select ' N の初期値は 7
Selection.PasteSpecial Paste:=xlPasteValues,Operation:=xlNone, SkipBlanks:=False,Transpose:=False
Application. CutCopyMode=False
Sheets("DT").Select
Range("Q" & intRow).Copy ' 工数の合計値だけを別にコピーしている。
Sheets("menu").Select
Range("Q" & N+Rn).Select
Selection.PasteSpecial Paste:=xlPasteValues,Operation:=xlNone, SkipBlanks:=False,Transpose:=False
Application.CutCopyMode=False
JumpNext:
Loop
GoTo JumpEnd
strSeib=TextBox1.Text ' 製番検索に入力すると、製番が strSeib に代入される。
If strSeib=" " Then Goto Jump2 ' strSeib にデータがないと Jump2
にジャンプする。
Set myRange=Worksheets("DT").Range("B5:B" & intRowE).Find(strSeib)
' DTシートのB列に strSeib があれば myRange に製番が入る。
If myRange Is Nothing Then Goto JumpERR ' myRange が空白なら JumpERR へジャンプする。
RG=8 ' menu シートのデータ貼り付け行位置
If myRange=strSeib Then ' 入力された製番と抽出された製番が同じなら、
intRow=myRange.Row ' 抽出された製番の行番号を intRow に代入する。
Sheets("DT").Select
Range("B" & intRow & ": P " & intRow).Copy '
B列からP列までの一行をコピーする。
Sheets("menu").Select
Range("B" & RG).Select
Selection.PasteSpecial Paste:=xlPasteValues,Operation:=xlNone, SkipBlanks:=False,Transpose:=False
' 値だけの貼り付けをする。
Application.CutCopyMode=False ' コピーモードの解除
End
Range("B5").Select
Application.ScreenUpdating=True ' マクロによる画面移動の停止を解除
GoTo JumpEnd ' JunpEnd へ移動する。
製番検索、機種・品名検索、納入先検索のいずれかに入力してから、
このボタンを押すと、[Private Sub CB1_Click( )]が実行されて、
データ抽出されB8からR8に表示される。
抽出されるデータが複数ある場合は下に並ぶ。
抽出.Show vbModeless でフォームを表示する。
vbModeless を付けると、フォームが出た状態でも
カーソルがシート上を移動できる。
If Range("B8")<> " " then '
B8空白でなかったら
intRowM=Sheets("menu").Range("B7").End(xlDown).Row ' B7から下にデータ行を調べて最下行番号を
' intRowMに代入する。
Else ' 違ったら、
intRowM=8 ' B8が空白ならintRowMに8を代入する。
End If
Range("A8:R" & intRowM).ClearContents ' A8からR最下行までデータを消去する。
このボタンを押すと、[抽出表示]マクロが実行されてフォームが表示される。
●ファイルの構成は、[工数の入力と抽出.xlsm] で入力と各製番の工数の読み出しと、[工数集計データベース.xlsm]
が保存するファイルである。
●VBAのプログラムポイントは、時間の計算とデータのFind抽出の実例である。
尚、文中の製番と機番は同じものである。
● このシステムは、作業工程ごとの工数を集計して、次回に同じ作業をするときの作業時間の予定を作成する為の
ものである。
● 各工程の工数の記入は、製作指示書システムで作成した、工程別の製作指示書に毎日作業者が、その製番の作業を
した時に、その作業時間を記入して完了時に提出する。その作業指示書の作業時間を集計するシステムである。
実践コース
工数集計システムから時間計算を学ぶ
実際に使っているシステムの内容で解説
EXCEL VBA 講座
