• 締切済み

タイムレポートの普通残業時間について

お世話になります。 Excel2007でタイムレポートを作成しております。 VBAで構文を作成しました。 30分以上で、残業発生。以降10分単位。29分は残業ではないというのが条件であります。 30分なら0:30 29分なら表示させない。35分ら0:30、40分なら0:40といった形です。 30分以上なら、普通残業を計算をするという構文を書いたのですが、 10分以上から0:10と表示されてしまいます。 8:30が定時、17:00が終了です。7:45が就業時間です。 普通残業は、17:00から22:00です。8:30分より早く来ても、8:30分から計算します。 たとえば、8:30 17:30なら、 7:45 0:30、 8:30 17:45なら 7:45 0:40です。 17:29なら普通残業は、表示させないようにしたいと思います。 →現状、0:20と表示されてしまいます。 -----------------------------------------------------------------------------   Public Sub CmpKintaiTime(prmINTIM, prmOUTTIM, prmKNMKBN, rtnSYUGYO, rtnHAYZAN, rtnFUTZAN, rtnSINZAN, rtnTIKOKU, rtnSOUTAI, rtnKYUZAN, rtnKYUSIN) '************************************************** ' 勤怠時間 算出 '************************************************** On Error GoTo ErrorTrap Dim wINTIM As Integer Dim wOUTTIM As Integer Dim wSTRTIM As Integer Dim wENDTIM As Integer Dim wSYUGYO As Variant Dim wFUTZAN As Variant Dim wSINZAN As Variant Dim wHAYZAN As Variant Dim wTIKOKU As Variant Dim wSOUTAI As Variant Dim wTIKOKUw As Variant Dim wSOUTAIw As Variant Dim wKYUZAN As Variant Dim wKYUSIN As Variant Dim wLower As Integer Dim wUpper As Integer Dim wIdx As Integer If IsTime(prmINTIM) = False Then GoTo ExitTrap End If If IsTime(prmOUTTIM) = False Then GoTo ExitTrap End If '時刻を分換算 wINTIM = Hour(prmINTIM) * 60 + Minute(prmINTIM) wOUTTIM = Hour(prmOUTTIM) * 60 + Minute(prmOUTTIM) '日付が変わった時刻は24時間加算 If wINTIM >= wOUTTIM Then wOUTTIM = wOUTTIM + (24 * 60) End If If wOUTTIM > khnENDTIM Then If wOUTTIM <= khnSTRFZN Then wOUTTIM = khnENDTIM Else If wOUTTIM > khnENDFZN Then If wOUTTIM <= khnSTRSZN Then wOUTTIM = khnENDFZN Else If wOUTTIM > khnENDSZN Then wOUTTIM = khnENDSZN End If End If End If End If End If wSYUGYO = Null wFUTZAN = Null wSINZAN = Null wHAYZAN = Null wTIKOKU = Null wSOUTAI = Null '就業時間算出 If wINTIM < khnSTRTIM Then wSTRTIM = khnSTRTIM Else wSTRTIM = wINTIM End If If wOUTTIM > khnENDTIM Then wENDTIM = khnENDTIM Else wENDTIM = wOUTTIM End If If wENDTIM > wSTRTIM Then wSYUGYO = wENDTIM - wSTRTIM Else wSYUGYO = 0 End If If prmKNMKBN <> 1 Then '平日のみ '遅刻 If wINTIM > khnSTRTIM Then wTIKOKU = wINTIM - khnSTRTIM End If '早退 If wOUTTIM < khnENDTIM Then wSOUTAI = khnENDTIM - wOUTTIM End If End If '早出残業算出 (始業時刻より早出残業判断分前に出勤した場合、早出を算出) If wINTIM <= (khnSTRTIM - khnHAYFUN) Then wHAYZAN = khnSTRTIM - wINTIM End If '普通残業算出 wFUTZAN = wOUTTIM - wINTIM - wSYUGYO If wFUTZAN >= 30 Then wFUTZAN = wOUTTIM - wINTIM - wSYUGYO End If ご教授くださいますようお願い申し上げます。 文章が長くて、最後まで読んでくださってありがとうございます。 お手数をおかけしますが、ご教授くださいますようお願いいたします。

みんなの回答

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.3

これを読者や回答者に読ませるのはひどいでしょう。 何かやり方が我流であるように思う。だから読む気がしない。 エクセルで作っているといいながら、シートやセル(行・列)の情況の説明が無く、データのシート上でと生んじゃっているのか例示も無いのはどうして。 エクセルの使用経験は相当あるのですか?あまり無くてVBAに魅力を感じて取り掛かり始めたところではないですか。 この課題はエクセル関数でも出来るものではないか。そしてよく関数の質問としても出る。 Googleで「エクセル 残業時間」などで照会すれば http://www.eurus.dti.ne.jp/~yoneyama/Excel/ex-q-a/q_jikoku.html http://www.eurus.dti.ne.jp/~yoneyama/Excel/nyumon/kinmu/index.html のような解説例が有り、基本的にはエクセルでは時間計算は(セルの値が時刻シリアル値なので)引き算でよいが、 MAX、MIN、FLOOR関数などを旨く使って式を短くしている。 だからそういう記事をよく勉強し、VBAで使えない関数があれば自作して、計算すれば簡単になるはず。 エクセルで時刻はセルの値は「数」であることをご存知か? Ceiling,Floor関数とVBA http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_050_030.html MIN、MAXとVBAは Sub test01() MsgBox WorksheetFunction.Min(Range("A1"), 10, 34) End Sub のようなのが可能。

全文を見る
すると、全ての回答が全文表示されます。
回答No.2

>30分以上なら、普通残業を計算をするという構文を書いたのですが、 と言うことなら、 >'普通残業算出 >wFUTZAN = wOUTTIM - wINTIM - wSYUGYO >If wFUTZAN >= 30 Then >wFUTZAN = wOUTTIM - wINTIM - wSYUGYO >End If と、wFUTZAN の計算式が30以上と未満で同じになるのはおかしいです。 下3行を以下のように書き換えたらどうでしょう? If wFUTZAN < 30 Then wFUTZAN = 0 以上

全文を見る
すると、全ての回答が全文表示されます。
  • edomin7777
  • ベストアンサー率40% (711/1750)
回答No.1

全く追いかける気はありません。 こういう時は、判定している変数(や計算に使っている変数)に何が入っているのかをmsgboxなんかを使って表示させてみるのが一番です。

全文を見る
すると、全ての回答が全文表示されます。

関連するQ&A

  • Excel VBAで別ブックのマクロから配列を取る

    Excel VBAで別ブックのマクロで計算した結果を配列で渡したいのですが、上手い方法が見つかりません。 同じブック内であれば、 Function GetAry(Imax As Integer, ByRef MyAry As Variant) as Boolean のような関数を作れば、GetAry = True の時に返値の MyAry が有効であるという判断ができますが、この関数を別ブックから使う場合は、参照渡しができません。 これはVBAの仕様なので仕方ないとして、以下のようなマクロを組んでみました。 '------------------------------------------------------- ' Book1.xlsm(呼び出される側) '------------------------------------------------------- Function MyAry(Imax As Integer) As Variant Dim i As Integer Dim SubAry() As Variant If Imax > 10 Then MyAry = False Else For i = 1 To Imax ReDim Preserve SubAry(i) SubAry(i) = i Next MyAry = SubAry End If End Function '------------------------------------------------------- ' Book2.xlsm(呼び出す側) '------------------------------------------------------- Sub GetMyAry() Dim DataAry As Variant Dim Imax As Integer Imax = 11 DataAry = Application.Run("Book1!MyAry", Imax) If DataAry <> False Then MsgBox UBound(DataAry) Else MsgBox DataAry End If End Sub '------------------------------------------------------- Imax = 11 であれば、メッセージボックスに False が表示されますが、Imax = 10 だと当然ですが「型が一致しません」というエラーになります。 エラートラップで誤魔化そうかとも思ったのですが、もっとスマートな方法がないでしょうか。 よろしくお願いします。

  • Accessレポートで1行おきに色を変える

    Private Sub 詳細_Print(Cancel As Integer, PrintCount As Integer) FontCount = FontCount + 1 If FontCount Mod 2 = 1 Then Me.Section(0).BackColor = 16777215 Else Me.Section(0).BackColor = 16777164 End If End Sub としてみました。 ですが何らかわりなく… 試しに Private Sub 詳細_Print(Cancel As Integer, PrintCount As Integer) FontCount = FontCount + 1 If FontCount Mod 2 = 1 Then Me.Section(0).BackColor = 16777215 Else Me.Section(0).BackColor = 16777164 End If MsgBox FontCount End Sub としてみたところずーっと「1」が表示され、変数がかわってないようです。 いったいどこがダメなのでしょうか? 確か以前できたはずなのに…(><)

  • データコンボのNullについて

    何度もすいませんm(__)m データコンボで 値が選択されてない場合は nullをデータベースに格納したいんですが、 できません。nullの使い方が不正です。と出ます。 教えてください。 VB6を使ってますデータベースはMySQLです。 Dim id As Integer If Me.DataCombo1.Text = "" Then id = Null Else id = Me.DataCombo1.SelectedItem End If datacombo1はInteger型のデータを データベースに格納します

  • macroについて教えてください

    こんにちは。以前こちらでPrivate SubについてMacroを教えていただきました。(あの後ログインパスワード等が不明になりお礼も出来ませんでしたが。。。回答頂いた方すみませんでした。) 下記がそのMacroですが、今回また少し変えることになり どのように変えていいのか分かりません。 前回は1~5はグレー、6~10は茶色・・・という形にしたのですが 今回は進捗率での管理をしたく、80%以下は白、80~90%は赤、90~100%は青としたいと思っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim iColors As Variant Dim rw As Long Dim CellCnt As Integer Dim col As Integer Dim col2 As Integer Dim i As Integer Dim j As Integer Dim k As Integer Dim c As Variant Dim ar() As Variant Dim Sh1 As Worksheet Set Sh1 = Worksheets("小児科Dr") col = Target.Cells(1).Column '制限された列 If Not (col = 4 Or col = 8 Or col = 12 Or col = 16) Then Exit Sub iColors = Array(16, 16, 16, 16, 16, 53, 53, 53, 53, 53, 54, 54, 54, 54, 54) CellCnt = Target.Count ReDim ar(CellCnt - 1) For Each c In Target If c.Value <> "" Then If IsNumeric(c.Value) Then i = c.Value If i >= 11 Then i = 10 End If If i > 0 And i < 11 Then j = iColors(i - 1) Else j = 2 End If ar(k) = j k = k + 1 End If End If Next c rw = Target.Row Select Case col Case 4: col2 = 2 Case 8: col2 = 8 Case 12: col2 = 14 Case 16: col2 = 20 'Sh1.Cells(rw + 2, 13).Resize(Int(Target.Count / 3), 3).Interior.ColorIndex = j End Select InsideColors Sh1, rw, col2, CellCnt, ar() Set Sh1 = Nothing End Sub Private Sub InsideColors(sh As Worksheet, _ rw As Long, _ col As Integer, _ cnt As Integer, _ ar As Variant) 'sh[シート],rw[行], col[列],cnt[セル個数],iColor[色指数] Dim i As Integer Dim j As Integer Dim n As Integer Dim k As Integer If cnt Mod 5 > 0 Then '範囲行数 i = (cnt + 5 - (cnt Mod 5)) / 5 Else i = cnt / 5 End If rw = Int((rw - 1) / 5) + 1 '行再設定 j = ((rw - 1) Mod 5) + 1 '列設定 For n = j To cnt sh.Cells(rw + 2, col).Resize(i, 5).Cells(n).Interior.ColorIndex = ar(k) k = k + 1 Next n End Sub 毎回他の人を頼ってしまい、申し訳ないのですがお願いします。 また、前回分からなかったので1~5を指定するときに5回同じカラー番号を書いたのですがこちらも良かったら手直し方法を教えていただければ助かります。 宜しくお願いします。

  • vba 初心者

    Dim a As Integer Dim inbox As String Dim Localpath As Variant Dim c As Range, myFadd As String Dim flag As Variant Dim MyShell As Object Dim Mysh As String Dim newHour As Variant Dim newMinute As Variant Dim newSecond As Variant Dim waitTime As Variant Localpath = ThisWorkbook.Path a = 1 inbox = InputBox("番号") Do If inbox = Empty Then Exit Sub End If If inbox = Cells(a, 1) Then MsgBox ("あります") Exit Do Else a = a + 1 ElseIf Cells(a, 1) <> inbox Then MsgBox ("ない") End If Loop Set MyShell = CreateObject("WScript.Shell") MyShell.Run ("AcroRd32.exe /n") MyShell.Run ("AcroRd32.exe /p") & Localpath & "\" & Myfile & ".pdf" newHour = Hour(Now()) newMinute = Minute(Now()) newSecond = Second(Now()) + 10 waitTime = TimeSerial(newHour, newMinute, newSecond) Application.Wait waitTime Application.SendKeys "{Enter}", True '次の使用例は、10 秒を過ぎるとメッセージを表示します。 If Application.Wait(Now + TimeValue("0:00:10")) Then MsgBox "時間が過ぎました。" End If End Sub ExcelからPDFファイルを検索して印刷したいのですが、 見よう見まねで作ってみたもののエラーが出てしまってよく分かりません。 指摘できるところご指導よろしくお願いします。

  • マクロ 記述が悪くエラーがかかります。

    いつも回答ありがとうございます。 最後らへんの記述で実行時エラー【型が一致しません】がかかります。 Worksheets("集計用").Range(b1, b2).Copy _ Destination:=Worksheets(b3).Range("B2") ← ここでエラーがかかる。 ワークシート名に変数を使用しているせいだと思います。 解決する方法を御指導して頂けないでしょうか?宜しくお願い致します。 Sub グラフの作成() Dim Date1 As Date Dim Date2 As Date Dim SName As String Dim b1 As Variant Dim b2 As Variant Dim b3 As Variant Dim d1 As Variant Dim d2 As Variant Dim d3 As Variant With Worksheets("集計用") s1: Date1 = Application.InputBox("最初の日付を2012/12/1のように入力してください。") If Date1 = 0 Then MsgBox "キャンセルされました。", vbOKOnly Exit Sub End If Set b1 = .Columns("B").Find(Date1, , xlValues, 1) If b1 Is Nothing Then If MsgBox("入力した日付が見当たりません。" & vbNewLine & _ "再度入力しますか?", vbYesNo) = vbYes Then GoTo s1 Else MsgBox "処理を中止しました", vbOKOnly Exit Sub End If End If d1 = b1.Row s2: Date2 = Application.InputBox("最初の日付を2012/12/31のように入力してください。") If Date1 = 0 Then MsgBox "キャンセルされました。", vbOKOnly Exit Sub End If Set b2 = .Columns("B").Find(Date2, , xlValues, 1) If b2 Is Nothing Then If MsgBox("入力した日付が見当たりません。" & vbNewLine & _ "再度入力しますか?", vbYesNo) = vbYes Then GoTo s2 Else MsgBox "処理を中止しました", vbOKOnly Exit Sub End If End If d2 = b2.Row s3: SName = Application.InputBox("商品名を入力して下さい。") If SName = "False" Then MsgBox "キャンセルされました。", vbOKOnly Exit Sub End If Set b3 = .Rows("3").Find(SName, , xlValues, 1) If b3 Is Nothing Then If MsgBox("入力した商品名が見当たりません。" & vbNewLine & _ "再度入力しますか?", vbYesNo) = vbYes Then GoTo s3 Else MsgBox "処理を中止しました", vbOKOnly Exit Sub End If End If d3 = b3.Column End With Worksheets.Add After:=Worksheets("集計用") ActiveSheet.Name = b3 Worksheets("集計用").Range(b1, b2).Copy _ Destination:=Worksheets(b3).Range("B2") Worksheets("集計用").Range(Cells(d1, d3), Cells(d2, d3)).Copy _ Destination:=Worksheets(b3).Range("C2") End Sub

  • ユーザー定義関数の再計算

    ユーザー定義関数を作りました。 ところが、この関数が自動再計算をしてくれません。 どうしたら自動再計算するようになるのでしょうか? よろしくお願いします。 ちなにこの関数は、自分のシートのB2とsheet1~sheet4のB9を比較して、正しければB9の4つ右のセルの値を合計して返すものです。 =SheetLook($B$2,"sheet1,sheet2,sheet3,sheet4",B9,4) コードです。 Function SheetLook(参照元 As Variant, 比較対象シート As String, 比較対象セル As Range, 参照セル位置 As Integer) As Variant   Dim i As Integer   Dim rng As Range   Dim sss As Variant   Dim kei As Variant   Dim cnt As Integer   sss = Split(比較対象シート, ",")   kei = 0   cnt = 0   For i = 0 To UBound(sss)     Set rng = Sheets(sss(i)).Range(比較対象セル.Address)     If 参照元 = rng Then       kei = kei + rng.Offset(0, 参照セル位置)       cnt = cnt + 1     End If   Next   If cnt <> 0 Then     SheetLook = kei   Else     SheetLook = ""   End If End Function

  • 昨日のプリンターの件です

    下記のようなことを記入してよいか迷ったのですが、wendy02さん、教えてください。 下記のように、プリンターを変えたところ、「設定がうまくいきませんでした」と出てきます。 何か、間違っていますでしょうか?但し、プリントは出来ました。 Dim OldPrt As String Dim ActPrt As String Dim i As Integer Dim errFlg As Integer OldPrt = Application.ActivePrinter ActPrt = "\\FMV-DESKPOWER\EPSON PM-4000PX on USB002" ActPrt = Trim(ActPrt) On Error Resume Next For i = 0 To 4 Application.ActivePrinter = ActPrt & " on Ne" & Format$(i, "00") & ":" If Err.Number > 0 Then errFlg = Err.Number Err.Clear Else errFlg = 0 Exit For End If Next i ActPrt = Application.ActivePrinter On Error GoTo 0 If ActPrt = OldPrt Then If errFlg > 0 Then MsgBox "設定がうまく行きませんでした", 48 Else MsgBox "設定はそのままで、使えます。", 64 End If ElseIf errFlg = 0 Then MsgBox "正しく設定されました: " & Application.ActivePrinter End If ''印刷(Excel の場合)

  • vba初心者

    いつもお世話様です。 A列にあらかじめデータを入れといてinboxでデータを検索してもしあったらPDFファイルを開いて印刷でもしデータがなかったらinboxに戻るかたちにしたいんですけど、do...loopの使い方が分からないのと、デバックがでてしまってどう直せばいいかわかりません。サンプルコードがあれば助かります。よろしくお願いします。 Dim a As Integer Dim inbox As String Dim Localpath As Variant Dim c As Range, myFadd As String Dim flag As Variant Dim MyShell As Object Dim Mysh As String Dim newHour As Variant Dim newMinute As Variant Dim newSecond As Variant Dim waitTime As Variant Localpath = ThisWorkbook.Path a = 1 inbox = InputBox("番号") Do If inbox = Empty Then Exit Sub End If If inbox = Cells(a, 1) Then MsgBox ("あります") Exit Do Else a = a + 1 ←ここでデバックがでてしまいます。 ElseIf Cells(a, 1) <> inbox Then MsgBox ("ない") End If Loop Set MyShell = CreateObject("WScript.Shell") MyShell.Run ("AcroRd32.exe /n") MyShell.Run ("AcroRd32.exe /p") & Localpath & "\" & Myfile & ".pdf" newHour = Hour(Now()) newMinute = Minute(Now()) newSecond = Second(Now()) + 10 waitTime = TimeSerial(newHour, newMinute, newSecond) Application.Wait waitTime Application.SendKeys "{Enter}", True '次の使用例は、10 秒を過ぎるとメッセージを表示します。 If Application.Wait(Now + TimeValue("0:00:10")) Then MsgBox "時間が過ぎました。" End If End Sub

  • Workbook

    次のプログラムをExcelのWorkbookで開くやり方がよくわかりません。 どうやってやるのか教えていただけないでしょうか? Option Explicit Const ALIVE As Integer = 1 Const DEAD As Integer = 0 Const BORN As Integer = 3 Const LIFE As Integer = 2 Const SIZE As Integer = 20 Const Tmax As Integer = 100 Dim C(SIZE, SIZE) As Integer Dim Xrange As Variant Private Sub LifeGame() Dim InitRate As Single Dim T As Integer Dim I As Integer, J As Integer Randomize Xrange = Range("A1:T20") InitRate = 0.5 For I = 1 To SIZE For J = 1 To SIZE If Rnd() < InitRate Then C(I, J) = ALIVE Else C(I, J) = DEAD End If Next J Next I For T = 1 To Tmax For I = 1 To SIZE For J = 1 To SIZE If C(I, J) = ALIVE Then Xrange(I, J) = "■" Else Xrange(I, J) = "" End If Next J Next I Range("A1:T20") = Xrange For I = 1 To SIZE For J = 1 To SIZE C(I, J) = Cnext(I, J) Next J Next I Next T End Sub Function Cnext(I As Integer, J As Integer) As Integer Dim xi As Integer Dim xj As Integer Dim xsum As Integer For xi = I - 1 To I + 1 For xj = J - 1 To J + 1 If (xi > 0 And xi <= SIZE) _ And (xj > 0 And xj <= SIZE) Then If Not (xi = I And xj = J) Then If C(xi, xj) = ALIVE Then xsum = xsum + 1 End If End If End If Next Next Select Case xsum Case BORN Cnext = ALIVE Case LIFE Cnext = C(I, J) Case Else Cnext = DEAD End Select End Function Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Call LifeGame End Sub

接続先1に接続しなくなった
このQ&Aのポイント
  • 本日、午後からネットが不通になりました。家庭内LANは生きていて、「192.168.1.1」に接続できます。
  • そこから「接続先設定画面」の中から「接続先1」の情報を見ると「未接続」となっています。
  • 『接続』をクリックしても接続されません(未接続の表示のまま)。
回答を見る

専門家に質問してみよう