以下のVBSを作り、コマンドラインから実行してください。
If WScript.Arguments.Count <> 1 Then
WScript.Echo "使用方法:" & vbNewLine & _
"Excelのパス名を1個だけコマンドラインで指定します"
Else
Dim APL, NUM, MSG
Set APL = CreateObject("Excel.Application")
On Error Resume Next
LogWrt WScript.Arguments(0)
NUM = Err.Number
MSG = Err.Description
On Error GoTo 0
APL.DisplayAlerts = False
APL.Quit
Set APL = Nothing
If NUM <> 0 Then Err.Raise NUM, , MSG
End If
Sub LogWrt(ByVal PTH)
Dim WKB, WKS
Dim I, J, DMX
Dim QRY, REC, TMP
On Error Resume Next
Set WKB = APL.Workbooks.Open(PTH)
If Err.Number <> 0 Then
Err.Clear
Set WKB = APL.Workbooks.Add
WKB.SaveAs PTH
End If
I = Err.Number
J = Err.Description
On Error GoTo 0
If I <> 0 Then
Err.Raise I, , J
Exit Sub
End If
If WKB.Worksheets.Count = 0 Then WKB.Worksheets.Add
Set WKS = WKB.Worksheets(1)
I = 1
Set QRY = CreateObject("WBemScripting.SWBemLocator"). _
ConnectServer(".").ExecQuery("SELECT TimeWritten " _
& "FROM Win32_NTLogEvent WHERE " _
& "EventCode=6006 And LogFile='System'")
DMX = -1
ReDim DWN(0)
For Each REC In QRY
DMX = DMX + 1
ReDim Preserve DWN(DMX)
TMP = REC.TimeWritten
DWN(DMX) = CDate(Left(TMP, 4) & "/" & Mid(TMP, 5, 2) & "/" & Mid(TMP, 7, 2) _
& " " & Mid(TMP, 9, 2) & ":" & Mid(TMP, 11, 2) & ":" & Mid(TMP, 13, 2))
Next
For J = 0 To DMX
Do
TMP = WKS.Cells(I, 1).Value
If VarType(TMP) <> vbDate Then Exit Do
If TMP > DWN(J) Then
I = I + 1
Else
If TMP < DWN(J) Then WKS.Cells(I, 1).EntireRow.Insert
Exit Do
End If
Loop
WKS.Cells(I, 1).Value = DWN(J)
I = I + 1
Next
WKB.Save
WKB.Close
End Sub
お礼
VBSの知識がゼロでしたので、私には難しすぎましたが、 力作をありがとうございました!!!