6-3(7) 出社時間と退勤時間で実務労働時間を出す
○●●（2001/2/10 A.Uさんから下記メールが来たので作成）
出社時間と退勤時間で実務労働時間を出すマクロを教えてください。
１５分単位での区切り
○拘束時間が６時間未満だと休憩無しなので実務労働時間は５時間４５分以下
○拘束時間が６時間以上７時間未満だと休憩が３０分なので
実務労働時間は５時間３０分以上６時間１５分
○拘束時間が７時間以上８時間未満だと休憩が４５分なので
実務労働時間は６時間１５分以上７時間００分
○拘束時間が８時間以上だと休憩が１時間なので
実務労働時間は７時間以上
出社時間と退社時間を入力すると実務労働時間が表示されるようにしたいのです。
入力は９：００だったら「0900」１８：００だったら「1800」
出勤時間が「0848」退勤時間が「1812」の場合は
出社時間は１２分早いが９：００、退勤時間は１２分オーバーしているが１８：００
と言う考えなので（どちらも１５分未満と言う事なので）
実務労働時間は８時間と言うようにしたのです。
また、出勤が「0912」だった場合は９:１５分と言う形です。
フレックス制なので出退勤の時間がばらばらで、人数も１００人を超えているので
このマクロが出来ればかなり管理が出来るようになります。
何か良いアドバイスをいただけないでしょか？
エクセルは２０００を使っています。
お願いします。教えてください。
(1)使い方
・上図のように作りました。B列の出社時間・C列の退社時間を入力すれば
自動的にD列へ勤労時間が表示されます。
・なお、依頼では入力は９：００だったら「0900」となっていますが、
Excelのシリアル時間をそのまま使用する関係で９：００は「09:00」
と入力すして下さい（もしどうしても「0900」と入れたいなら、
ユーザーフォームで「0900」と入力しセルには「09:00」と入るよう改善
して下さい）
・下記オブジェクトで、Sub 文字設定()は新規のファイルを作成した時
1度実行して下さい。Sub 再チェック()は特に実行する必要ありませんが、
もし、B列又はC列へ入力してもD列が変化しない場合実行して下さい
（再帰呼び出し禁止のためEnableEvents = Falseにしてあるが、
エラー等発生した場合Excelのイベントが発生しない状態になって
しまうため、もしそのようになったら「再チェック」を実施する）
・拘束時間が８時間以上の残業時間も休息時間が必要なはずですが、質問に
なかったので折込んでありますん。
----------------------------------------------------------------
(2)マクロ説明
・Private Sub ・・・は対象シートのクラスモジュールへ貼り付けて
下さい。2列と3列のでを取り込むようになっています。
・他は標準モジュールへ貼り付ける。
・マクロのポイントとしては、Excelの1分は=1/24/60→0.000694444で
シリアル値で各種処理をして最後に時間にしてあります。
・D列に拘束時間を出していますが、この表示は依頼にはなく半分
デバッグ用に付けたものです。要らない場合は'(不用の場合カット）
と記述してある個所をカットして下さい。
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 2 Or Target.Column = 3 Then
r = Target.Row
Call zikan
End If
Application.EnableEvents = True
End Sub
Public r As Integer
Dim st As Date
Dim et As Date
Sub zikan()
Const m1 As Single = 0.000694444 '1分
Const m15 As Single = 0.010416667 '15分
Const m30 As Single = 0.02083332 '30分
Const m45 As Single = 0.03124998 '45分
Const h1 As Single = 0.041666667 '1H
Const h6 As Single = 0.250000002 '6H
Const h7 As Single = 0.291666669 '7H
Const h8 As Single = 0.333333336 '8H
st = Cells(r, 2)
et = Cells(r, 3)
'9:00前補正
If st < TimeValue("9:00") Then
st = TimeValue("9:00")
End If
'スタートの15分補正
st1 = Int(st / m15)
st = (st1 + 1) * m15
'終了の15分補正
et = et + m1
et1 = Int(et / m15)
et = (et1) * m15
'拘束時間
soku1 = et - st
soku3 = soku1 '(不用の場合カット）
'6H
If soku1 < h6 Then
GoTo pass1
End If
'6H-7H
If soku1 >= h6 And soku1 < h7 Then
soku1 = soku1 - m30
GoTo pass1
End If
'7H-8H
If soku1 >= h7 And soku1 < h8 Then
soku1 = soku1 - m45
GoTo pass1
End If
'8H
If soku1 >= h8 Then
soku1 = soku1 - h1
End If
pass1:
soku2 = CDate(soku1)
On Error Resume Next
Cells(r, 4) = soku2
Cells(r, 6) = soku3 '(不用の場合カット）
If Err = 0 Then
On Error GoTo 0
ElseIf Err = 1004 Then
On Error GoTo 0
Else
MsgBox "予期せぬエラー"
End If
End Sub
Sub 文字設定()
Columns("D:D").Select
Selection.NumberFormatLocal = "h:mm"
Range("D1").Select
'(不用の場合カット）
Columns("F:F").Select
With Selection.Font
.Size = 8
End With
Selection.NumberFormatLocal = "h:mm"
Range("F1").Select
End Sub
Sub 再チェック()
Application.EnableEvents = True
Selection.SpecialCells(xlCellTypeLastCell).Select
endr = ActiveCell.Row
For r = 2 To endr
Call zikan
Next
End Sub
6-3(8) 指定したセルへ画像を貼り付け
○●●
ワークシートに画像を張付ける場合、マニアル操作でメニューから
[挿入][図][ファイルから]を選択して画像フェイルを指定して貼り付け
その後任意の場所に移動すると共にサイズを変更すれば希望のセルへ
画像を張付けることが出来す。
しかし、ワークシートへ多数の画像を張付ける場合マニアル操作は
面倒であり、下記マクロでセル範囲を指定し簡単に貼り付けることが
できます。（本例ではセル範囲は固定になっていますが実際の使用では
インプットボックスで行なうとよい）（サンプル掲載「KIgazou1」)
Sub Macro1()
'セル範囲
Set scel = Range(Cells(2, 2), Cells(12, 5))
scel.Select
x = ActiveCell.Column
y = ActiveCell.Row
x2 = Selection.Width
y2 = Selection.Height
Range("A1").Select
fname = Application.GetOpenFilename _
("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい")
If fname = False Then
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Pictures.Insert(fname).Select
Selection.Name = "gazou"
Set 画像 = ActiveSheet.Shapes("gazou")
With 画像
.LockAspectRatio = False
' .LockAspectRatio = True '比率変換
.Placement = xlFreeFloating
.ScaleHeight 1, True
.ScaleWidth 1, True
.Left = Cells(y, x).Left
.Top = Cells(y, x).Top
.Width = x2
.Height = y2
End With
Range("A1").Select
End Sub
・上記の.LockAspectRatio = FalseをTrue にかえれば比率変換となります。
・図形の指定は必要に応じ「*.jpge;*.tif;*.tiff」等を追加して下さい。
6-3(9) 画像を分割して貼り付け
○●●
前項で指定したセルへ貼り付けたが、これはマニアル操作でも出来ることであり、
マクロとしては画像を分割し貼り付けることが出来ないか考えて作成したのが
下記マクロです。
・下記例では分割数を縦・横とも５個
・分割画像を別の場所に貼り付ける場合は、選択状態にしてドラッグする。
・複数個を選択する場合はShiftキーを押しながら実行
・なお、移動させた画像は選択状態で右クリックしてショートタットメニュのグループ化
指定で1個の画像になります。
・分割と表示倍率をユーザーフォームで指定するサンプル掲載は、[KIgazou2]
Dim 絵1 As Object '分割用の絵
Dim bw As Single '分割の1個の横幅
Dim bww As Single '分割の1個の横幅
Dim bh As Single '分割の1個の縦幅
Dim bhh As Single '分割の1個の縦幅
Dim ien As Integer '横の分割数
Dim jen As Integer '縦の分割数
Dim i As Integer '横
Dim j As Integer '縦
Dim yoko As Integer '横
Dim tate As Integer '縦
Sub 分割実行()
ien = 5 '分割横数
jen = 5 '分割縦数
'画像ファイル指定
fname = Application.GetOpenFilename _
("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい")
If fname = False Then
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Pictures.Insert(fname).Select
Selection.Name = "gazou"
'分割の1個の縦横幅
Set 絵 = ActiveSheet.Shapes("gazou")
bww = 絵.Width
bw = bww / ien
bw = CInt(bw / 0.75) * 0.75
bhh = 絵.Height
bh = CInt(bhh / jen)
bh = CInt(bh / 0.75) * 0.75
'元の絵
Set 絵 = ActiveSheet.Shapes("gazou")
With 絵
.LockAspectRatio = True
.Placement = xlFreeFloating
.ScaleHeight 1, False
.ScaleWidth 1, False
.Left = Cells(2, 2).Left
.Top = Cells(2, 2).Top
End With
bunno = 1
For i = 1 To ien
For j = 1 To jen
'分割用の絵
Set 絵1 = 絵.Duplicate
絵1.Select
絵1.Left = Cells(2, 2).Left
絵1.Top = Cells(2, 2).Top
'縦横の位置
yoko = (bunno - 1) Mod ien + 1
tate = (bunno - 1) \ ien + 1
絵1.LockAspectRatio = False
With 絵1.PictureFormat
.CropLeft = bw * (yoko - 1)
.CropRight = bww - (bw * yoko)
.CropTop = bh * (tate - 1)
.CropBottom = bhh - (bh * tate)
End With
bunno = bunno + 1
Set 絵1 = Nothing
Next
Next
絵.Delete
Range("A4").Select
End Sub
・".ScaleHeight 1, False"の1は倍率であり変更により表示サイズが変わる。
・"絵.Delete"で元の絵を削除してあるが、この指定が無い場合は下絵が残ります。
・表示とトリミングのポイント位置は同じであっても空白が出来きる。
0.75(1ポイント)で余りの出ない数に補正してあります。
6-3(10) 日本歴を西歴に変換例1
○●●
下図のシートを昭和/平成に分割する必要があり作成
Sub 西暦化マクロ()
'最終セル
ActiveCell.SpecialCells(xlLastCell).Select
endr = ActiveCell.Row
Cells(1, 8) = "・"
Cells(1, 9) = "・"
' ６列を１０列へコピー
Columns("F:F").Select
Selection.Copy
Range("J1").Select
ActiveSheet.Paste
Range("H2").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("K9").Select
' 元年を1年へ
Columns("J:J").Select
Selection.Replace What:="元", Replacement:="1", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("J14").Select
' 全角を半角へ
For i = 2 To endr
Application.StatusBar = "全角→半角---- " & i & "/" & endr
Cells(i, 10) = StrConv(Cells(i, 10), 8)
Next
' 年文字削除
Application.StatusBar = "--年文字削除中--- "
Columns("J:J").Select
Selection.Replace What:="年", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("I11").Select
'西暦へ変更
For i = 2 To endr
Application.StatusBar = "西暦化---- " & i & "/" & endr
On Error GoTo paserr
If InStr(1, Cells(i, 10), "昭和", 1) > 0 Then
nen = Mid(Cells(i, 10), 3, 2)
Cells(i, 10) = nen + 1925
GoTo pas
End If
If InStr(1, Cells(i, 10), "平成", 1) > 0 Then
nen = Mid(Cells(i, 10), 3, 2)
Cells(i, 10) = nen + 1988
GoTo pas
End If
If InStr(1, Cells(i, 10), "大正", 1) > 0 Then
nen = Mid(Cells(i, 10), 3, 2)
Cells(i, 10) = nen + 1911
End If
If Cells(i, 10) = "" Then
Cells(i, 10) = "?"
End If
pas:
Next
GoTo pas2
paserr:
MsgBox i & "行が変換できません。正しい文字に直して再実行して下さい"
On Error GoTo 0
pas2:
End Sub
実際の分割はメニューから、「データ」「フィルタ」「オートフィルタ」で
作成したJ列を1988より大きい、1989より小さいで実行。
6-3(11) 日本歴を西歴に変換例２
○●●（2002/08/30 (金) 19:36 Iさんから下記メールが来たので作成）
年式を西暦に変換するところで、過去に井領さんには（Ｈ
１２年４月）を２０００と変換していただいたのですが、これを年と月を分けて取り
出したいのです。セル（ｉ，２）に２０００/４とするか、フィールド（Ｍｏｎ）を
追加してそこ（i, 3)?にデータ（Ａｐｒｉｌ）を差し込む形にしたいのですが、どの
ようにしたらようのでしょうか？
（Ｌｅｆｔ関数は左から数えた文字数分だけ拾うようですが、その中で２種類の数字
を取り出すにはどうしたらよいものかと．．．）
本例の場合はExcelが判断出来る日付形式にすれば表示形式を指定できます。
以下マクロの内容
[1] Excelが判断出来る日付形式にする(日付も必要であり適当な日を付加)
[2] 表示形式を"yyyy/mm"に指定
[3] 日本語全角を半角にし変数に代入
[4] 変数に入れたデータを再度セルへ入れる
※ [2]の指定形式するためには、[4]のように再度入力が必要
'H14/12/1 形式にする
Columns("B:B").Select
Selection.Replace What:="年?", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="月", Replacement:="/1", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("E13").Select
'最終せる
Selection.SpecialCells(xlCellTypeLastCell).Select
endr = ActiveCell.Row
Range("A1").Select
'表示形式を"yyyy/mm"
Columns("B:B").Select
Application.CutCopyMode = False
Selection.NumberFormatLocal = "yyyy/mm"
For i = 2 To endr
Application.StatusBar = "西暦化---- " & i & "/" & endr
yymm = StrConv(Cells(i, 2), 8)
Cells(i, 2) = yymm
Next
6-3(12) 乱数で抽出数字のダブリ数字の回避
○●●（2002/07/08 (月) 17:21 W.Tさんから下記メールが来たので作成）
乱数で１から５０までのすうじで５個数字を表示させるとき
前と同じ数字が出ないようにする命令はどうすればいいのか
教えてください。よろしくお願いします
例2988aは、数字を確定する前に過去に出た数字をForステートメントでチェックし、
同じ数字があった場合再度乱数で数字抽出。
例2988bは、過去数字チェックをForステートメントでは数千以上の数字を抽出の場合
時間が掛かり実用的でないのでFindメソッドでチェックした例
質問は1〜50の数字の内5個表示であり45個の余裕な数字があり、例2988a・bの方法で
問題ないが、余裕数字がない場合はこの方法ではDoループを繰り返し無限ループに
なると思わる。もし、「1〜50の数字を50箇所にダブリなしで表示」のケースでは
例2988a・例2988bは使用しないで下さい。
この場合は例2988cのように1〜50の数字を予め入れてしまい、入っている入物の
方を乱数で表示個所の順序を変えればよい。
Sub 例2988a()
Randomize
For i = 1 To 5
Do
tmp = Int(50 * Rnd + 1)
mm = 0
For j = 1 To i - 1
If Cells(j, 1) = tmp Then
mm = 1
Exit For
End If
Next
If mm = 0 Then
Cells(i, 1) = tmp
Exit Do
End If
Loop
Next
End Sub
'-----------------------------------------------------------
Sub 例2988b()
Randomize
For i = 1 To 5
Do
tmp = Int(50 * Rnd + 1)
Columns("A:A").Select
Set actv = Selection.Find(tmp, , , xlWhole, xlByColumns, xlNext, True)
If actv Is Nothing Then
Cells(i, 1) = tmp
Exit Do
End If
Loop
Next
Range("A1").Select
End Sub
'-----------------------------------------------------------
Sub 例2988c()
Randomize
For i = 1 To 50
Cells(i, 1) = i
Next
For i = 1 To 50
rono = Int(50 * Rnd + 1)
mmsu = Cells(i, 1)
Cells(i, 1) = Cells(rono, 1)
Cells(rono, 1) = mmsu
Next
End Sub
6-3(13) 216色を6角形に表示
○●●前項のカラーは6個のブロックになっているのでこれを
Web上で6角形に表示し操作しようと考えた。始め6角形のセル位置を計算
しながらそこへHTMLタグの記述を考えたがこれは難しくて簡単に出来ないので、
簡単に指定したセルへ指定の文字を記入する方法として本例を考えた。
＜説明＞
概略：セルへ番号(行)を記述し、別シートのその番号データを転記する。
[1] 最終的には「図1」のようなカラーサンプルを作成（縦長になってしまった）
[2] まず「図2」のように6角形を書き、表示したい色のある行番号を記述
[3] 「図3」は表示される色を別シートに記述した例
[4] 「図2」のシートをアクティブにして下記マクロcolor216()を実行
[5] マクロ実行で「図4」が作成される
[6] 図4シートに対し「KIweb」を実行すると「図1」のテーブルが作成される
（HTML変換の時は、六角の目安に入れた線は削除してあります）
Sub color216()
Worksheets("Sheet4").Select
Set myrang = Range(Cells(1, 1), Cells(20, 16))
For Each myobj In myrang
cc = myobj.Select
su = Selection.Value
If su <> "" Then
Selection.Value = Sheets("Sheet1").Cells(su, 3).Value
End If
Next
End Sub
なお、この色見本を実際に使用したページは、
こちらです（ジャンプした場合はWebの「戻る」で戻って下さい。
6-3(14) コマンドバーのID番号表
ツールボタンにアイコンを表示する場合はFaceId番号を使用します。下表の
番号をクリックで実際のイメージが表示されます。
＜使用例 & 説明＞
← 下記マクロで表示したツールバー
[1] .Delete →ツールバーは毎回作成の関係で前に作成分の削除が必要
[2] .Position = msoBarTop → ツールバーをトップへ表示
[3] temporary:=True →Excel終了で本ツールバーは消える。
[4] .BeginGroup = True → ツールバーに区切りの縦線を入れる
[5] .Caption = "画像の取り込み" → マウスが来た時の説明文
[6] .OnAction = "画像" → アイコンをクリックした時実行するマクロ
[7] ID:=23 → クリックで実際の機能が実行される（注意：この指定でエラーになる番号もある）
[8] .FaceId = 931 → 表示するアイコン(この指定では全表示できるが、表示しているだけなので
実行するマクロの指定が必要。
Sub bar()
Dim cb As CommandBar
On Error Resume Next
CommandBars("mycb").Delete
On Error GoTo 0
Set cb = Application.CommandBars.Add(Name:="mycb", temporary:=True)
With cb
.Controls.Add Type:=msoControlButton, ID:=23, before:=1
.Controls.Add Type:=msoControlButton, ID:=3, before:=2
.Visible = True
.Position = msoBarTop
End With
Set cb1 = cb.Controls.Add(Type:=msoControlButton, before:=3)
With cb1
.BeginGroup = True
.Caption = "画像の取り込み"
.FaceId = 931
.OnAction = "画像"
End With
Set cb2 = cb.Controls.Add(Type:=msoControlButton, before:=4)
With cb2
.Caption = "枠内を透過にする"
.FaceId = 59
.OnAction = "透過"
End With
End Sub
【戻る】 【Top画面】 【HPへ】