| |
指定フォルダからTextファイルを読み込む様に改造して見ました
改変に共ない、指定フォルダの読み込み済み、ファイルを区別する為
マクロの有るBookに、FileListと言うシートが作られ、
ファイルのリストが作成されます
尚、一定時間毎にフォルダを探索するコードは作った事が無いので
上手く行かないかも？
現状では、「Sub SetTimer」を実行すると、10分間隔で17時30分まで動く様に
成ってますが、直近の時間で試して下さい
（動かすと時間に成らないと、止め様が無いかも？）
また、データも、シートのレイアウトも無いのでTestはしていません
以下のプロシージャは、使用しないので削除
Private Function GetReadFile
以下のプロシージャは、変更が無いので其のまま使用
Private Function GetDateColumn
Private Function GetTagNoRow
Private Function DataSearch
以下のプロシージャは、新規追加
Public Sub SetTimer
Private Sub Execution
Private Sub FileListCheck
Private Function GetAppendFile
Private Function GetFilesList
以下のプロシージャは、変更
Public Sub CrossTabulation（旧名 Public Sub データ収集()）
Option Explicit
Public Sub SetTimer()
'実行間隔指定（10分間隔）
Application.OnTime Time + TimeValue("00:10:00"), "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]~[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
以下後半に続く
|
|
Hirofumi
- 05/9/4(日) 2:15 -
