| |
提示されているサンプルデータでテストした限りでは、
以下のようなコードでうまくいきましたが・・。
Sub MyDayJob_TotalTime()
Dim Sh As Worksheet
Dim MyR As Range, C As Range
Dim Dy1 As Date, Dy2 As Date, MyD As Date
Dim GetT As Long, Mt As Long
Dim GetD As String
Dim SetD As Variant
Set Sh = Worksheets("Sheet2")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
With Worksheets("Sheet1")
.Rows(1).Insert xlShiftDown
.Range("A1:D1").Value = _
Array("DAY", "TIME1", "TIME2", "TOTAL")
Set MyR = .Range("A2", .Range("A65536").End(xlUp)) _
.Offset(, 3)
For Each C In MyR
Dy1 = C.Offset(, -2).Value: Dy2 = C.Offset(, -1).Value
If Dy1 < Dy2 Then
GetT = DateDiff("n", Dy1, Dy2)
If GetT >= 60 Then
Mt = GetT Mod 60
If Mt = 0 Then
C.Value = Format(GetT / 60, "00") & ":00"
Else
C.Value = Format(GetT \ 60, "00") & ":" & Mt
End If
Else
C.Value = "00:" & GetT
End If
Else
MyD = TimeValue("23:59:59") - Dy1 + Dy2 + _
TimeValue("00:00:01")
C.Value = Format(MyD, "hh:mm")
End If
Next
.Range("A1").Subtotal 1, xlSum, Array(4)
Set MyR = .Range("D2", .Range("D65536") _
.End(xlUp).Offset(-1)).SpecialCells(3, 1)
For Each C In MyR
GetD = Val(C.Offset(, -3).Value) & "日"
SetD = Application.Match(GetD, Sh.Range("A:A"), 0)
If Not IsError(SetD) Then
Sh.Cells(SetD, 2).Value = Format(C.Value, "hh:mm")
End If
Next
.Cells.RemoveSubtotal
.Rows(1).Delete xlShiftUp
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Sh.Activate: Set MyR = Nothing: Set Sh = Nothing
End Sub
|
|
Kein
- 06/8/12(土) 0:46 -
