| |
後半
Private Sub Workbook_Open()
'実行間隔指定（10分間隔）
Application.OnTime Time + TimeValue("00:00:15"), "Execution"
End Sub
Private Sub Execution()
'終了時間設定
If Time < #5:30:00 PM# Then
CrossTabulation
SetTimer
End If
End Sub
Public Sub CrossTabulation()
'日付の先頭位置の前の列
Const clngTop As Long = 11
'ファイル名Listの有るシート名
Const cstrList As String = "FileList"
Dim i As Long
Dim j As Long
Dim strPath As String
Dim vntFileNames As Variant
Dim dfn As Integer
Dim vntField As Variant
Dim strBuff As String
Dim lngCol As Long
Dim lngRow As Long
Dim rngScope As Range
Dim rngResult As Range
Dim rngDate As Range
Dim wksFiles As Worksheet
Dim rngLog As Range
Dim lngLog As Long
Dim vntLog(3) As Variant
'ファイル名Listの有るシートの確認
FileListCheck cstrList, wksFiles
'Log書き込み位置指定
Set rngLog = wksFiles.Cells(2, "D")
With rngLog
lngLog = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
End With
'Textファイルの有るフォルダを指定
strPath = "C:\system"
'読み込むファイルを取得(ダイアログを出さないで、指定フォルダから取得の場合）
If Not GetAppendFile(vntFileNames, strPath, "txt", _
"^[0-9][0-9][0-9][0-9][0-9][0-9]da~["", 0-9]*$", wksFiles) Then '←修正してみました。
GoTo Wayout
End If
' Application.ScreenUpdating = False
'ActiveSheetのA1セルを基準とする（Listの左上隅）
Set rngResult = ActiveSheet.Cells(7, "A")
With rngResult
'日付の書かれている列数を取得
lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
- .Offset(, clngTop).Column
'日付列の範囲を取得
If lngCol > 0 Then
Set rngDate = .Offset(, clngTop + 1).Resize(, lngCol)
End If
'No.が有る行数を取得
lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
'No.が有る範囲を取得
If lngRow > 0 Then
Set rngScope = .Offset(1).Resize(lngRow)
End If
End With
For i = 1 To UBound(vntFileNames)
j = 0
'指定されたファイルをOpen
dfn = FreeFile
Open vntFileNames(i) For Input As dfn
'ファイルから日付を取得
Do Until EOF(dfn)
'ファイルから１行読み込み
Line Input #dfn, strBuff
j = j + 1
'フィールドに分割
vntField = Split(strBuff, ",", , vbBinaryCompare)
'「20050731」形式の日付をシリアル値に変換
vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
& "/" & Mid(vntField(0), 5, 2) _
& "/" & Right(vntField(0), 2)))
'日付を探索
lngCol = GetDateColumn(vntField(0), rngDate, _
rngResult.Offset(, clngTop)) + clngTop
If lngCol = 0 + clngTop Then
'日付が表に無く中止した場合、Logを出力
vntLog(0) = Date
vntLog(1) = Time
vntLog(2) = vntFileNames(i)
vntLog(3) = j & "行目、" & Format(vntField(0), "yyyy/m/d") _
& " 日付無しに因り読み込み中止"
rngLog.Offset(lngLog).Resize(, 4).Value = vntLog
lngLog = lngLog + 1
Exit Do
Else
'No.を探索
lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
'日付、Noの交差するセルに値を書き込み
With rngResult.Offset(lngRow, lngCol)
.NumberFormatLocal = "G/標準"
.Value = vntField(6)
End With
End If
Loop
Close #dfn
Next i
Wayout:
' Application.ScreenUpdating = True
Set rngScope = Nothing
Set rngDate = Nothing
Set rngResult = Nothing
Set wksFiles = Nothing
Set rngLog = Nothing
Beep
End Sub
Private Sub FileListCheck(strSheet As String, wksFiles As Worksheet)
Dim blnExist As Boolean
With ThisWorkbook
For Each wksFiles In .Worksheets
If StrComp(wksFiles.Name, _
strSheet, vbTextCompare) = 0 Then
blnExist = True
Exit For
End If
Next wksFiles
If Not blnExist Then
With .Worksheets
Set wksFiles = .Add(After:=.Item(.Count))
wksFiles.Name = strSheet
End With
End If
End With
End Sub
Private Function GetAppendFile(vntFileNames As Variant, _
strFilePath As String, _
strExtePattan As String, _
strNamePattan As String, _
wksFiles As Worksheet) As Boolean
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim dicIndex As Object
Dim rngList As Range
Dim vntData As Variant
Dim vntAppend() As Variant
Dim vntRead As Variant
Set rngList = wksFiles.Cells(2, "A")
'読み込むファイル名を取得
If Not GetFilesList(vntRead, strFilePath, _
strExtePattan, strNamePattan) Then
GoTo Wayout
End If
With rngList
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
If lngRows < 1 Then
lngRows = 0
Else
vntData = .Resize(lngRows).Value
ReDim Preserve vntData(1 To lngRows, 1 To 2)
End If
End With
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
For i = 1 To lngRows
.Add vntData(i, 1), i
Next i
j = 0
For i = 1 To UBound(vntRead)
If .Exists(vntRead(i)) Then
vntData(.Item(vntRead(i)), 2) = "*"
Else
j = j + 1
ReDim Preserve vntAppend(1 To j)
vntAppend(j) = vntRead(i)
End If
Next i
End With
Set dicIndex = Nothing
If j > 0 Then
vntFileNames = vntAppend
GetAppendFile = True
End If
'データ全てに就いて繰り返し
j = 0
For i = 1 To lngRows
'もし、対象データが""で無いなら
If vntData(i, 2) <> "" Then
'書き込み位置を更新
j = j + 1
'配列の対象位置のデータを書き込み位置に代入
vntData(j, 1) = vntData(i, 1)
vntData(j, 2) = vntData(i, 2)
End If
Next i
With rngList
If lngRows > 0 Then
.Resize(lngRows, 2).ClearContents
.Resize(j, 2).Value = vntData
End If
If VarType(vntFileNames) = vbArray + vbVariant Then
.Offset(j).Resize(UBound(vntFileNames)).Value _
= Application.Transpose(vntFileNames)
End If
End With
Wayout:
Set rngList = Nothing
End Function
Private Function GetFilesList(vntFileNames As Variant, _
strFilePath As String, _
Optional strExtePattan As String = ".*", _
Optional strNamePattan As String = ".*") As Boolean
Dim i As Long
Dim objFiles As Object
Dim objFile As Object
Dim regExten As Object
Dim regName As Object
Dim vntRead() As Variant
Dim strName As String
Dim objFso As Object
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'フォルダの存在確認
If Not objFso.FolderExists(strFilePath) Then
GoTo Wayout
End If
'regExtenpのオブジェクトを取得（正規表現を作成）
Set regExten = CreateObject("VBScript.RegExp")
With regExten
'パターンを設定
.Pattern = strExtePattan
'大文字と小文字を区別しないように設定
.IgnoreCase = True
End With
Set regName = CreateObject("VBScript.RegExp")
With regName
'パターンを設定
.Pattern = strNamePattan
'大文字と小文字を区別しないように設定
.IgnoreCase = True
End With
'フォルダオブジェクトを取得
Set objFiles = objFso.GetFolder(strFilePath).Files
'ファイルの数が0でなければ
If objFiles.Count <> 0 Then
For Each objFile In objFiles
With objFile
strName = .Name
'検索をテスト
If regExten.Test(objFso.GetExtensionName(strName)) Then
If regName.Test(objFso.GetBaseName(strName)) Then
i = i + 1
ReDim Preserve vntRead(1 To i)
vntRead(i) = strName
End If
End If
End With
Next objFile
End If
Set regExten = Nothing
Set regName = Nothing
If i <> 0 Then
ReDim vntFileNames(1 To UBound(vntRead))
For i = 1 To UBound(vntRead)
vntFileNames(i) _
= StrConv(strFilePath & "\" & vntRead(i), vbNarrow)
Next i
GetFilesList = True
End If
Wayout:
'フォルダオブジェクトを破棄
Set objFiles = Nothing
Set objFile = Nothing
Set objFso = Nothing
End Function
End Function
|
|
ミツコ
- 05/9/4(日) 9:14 -
