| |
Option Explicit
Public Sub CrossTabulation()
'日付の先頭位置の前の列
Const clngTop As Long = 0
'ファイル名Listの有るシート名
Const cstrList As String = "FileList"
Dim i 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
'ファイル名Listの有るシートの確認
FileListCheck cstrList, wksFiles
'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][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 = ThisWorkbook.Worksheets("Sheet1").Cells(1, "A")
With rngResult
'日付の書かれている行数を取得
lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
'日付列の範囲を取得
If lngRow > 0 Then
Set rngDate = .Offset(clngTop + 1).Resize(lngRow)
End If
'No.が有る列数を取得
lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
- .Offset(, clngTop).Column
'No.が有る範囲を取得
If lngCol > 0 Then
Set rngScope = .Offset(, 1).Resize(lngCol)
End If
End With
For i = 1 To UBound(vntFileNames)
'指定されたファイルをOpen
dfn = FreeFile
Open vntFileNames(i) For Input As dfn
'ファイルから日付を取得
Do Until EOF(dfn)
'ファイルから１行読み込み
Line Input #dfn, strBuff
'フィールドに分割
vntField = Split(strBuff, ",", , vbBinaryCompare)
'「20050731」形式の日付をシリアル値に変換
vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
& "/" & Mid(vntField(0), 5, 2) _
& "/" & Right(vntField(0), 2)))
'日付を探索
lngRow = GetDateColumn(vntField(0), rngDate, _
rngResult.Offset(, clngTop)) + clngTop
'No.を探索
lngCol = GetTagNoRow(vntField(5), rngScope, rngResult)
'日付、Noの交差するセルに値を書き込み
With rngResult.Offset(lngRow, lngCol)
.NumberFormatLocal = "G/標準"
.Value = vntField(6)
End With
Loop
Close #dfn
Next i
Wayout:
Application.ScreenUpdating = True
Set rngScope = Nothing
Set rngDate = Nothing
Set rngResult = Nothing
Set wksFiles = Nothing
Beep
End Sub
Private Function GetDateColumn(vntDate As Variant, _
rngScope As Range, _
rngDateTop As Range) As Long
Dim lngFound As Long
Dim lngOver As Long
Dim lngCount As Long
'日付範囲に日付が無いなら
If rngScope Is Nothing Then
lngFound = 0
lngCount = 0
lngOver = 1
Else
'日付の探索
'セル値が数値として入力されている場合
lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
'セル値が文字列として入力されている場合
' lngFound = DataSearch(vntDate, rngScope, lngOver)
lngCount = rngScope.Columns.Count
End If
'日付が見つかった場合
If lngFound > 0 Then
'位置を返す
GetDaterowlngFound
Else
With rngDateTop
'日付が最終列の以内の場合
If lngOver <= lngCount Then
'指定位置に列を挿入
.Offset(lngOver).EntireColumn.Insert
End If
'日付を書き込み
With .Offset(lngOver)
.NumberFormatLocal = "m/d"
.Value = vntDate
End With
'挿入位置を返す
GetDateColumn = lngOver
'日付行の範囲を更新
Set rngScope _
= .Offset(1).Resize(lngCount + 1)
End With
End If
End Function
Private Function GetTagNoRow(vntTagNo As Variant, _
rngScope As Range, _
rngListTop As Range) As Long
Dim lngFound As Long
Dim lngCount As Long
'No範囲にNoが無いなら
If rngScope Is Nothing Then
lngFound = 0
lngCount = 0
Else
'Noを探索
lngFound = DataSearch(vntTagNo, rngScope, , 0)
lngCount = rngScope.Rows.Count
End If
'探索成功（Noが有るなら）
If lngFound > 0 Then
'位置を返す
GetTagNoRow = lngFound
Else
With rngListTop
'行末位置を更新
lngCount = lngCount + 1
'セルの書式を文字列に設定
'(001の様な場合無いと探索が出来ない）
.Offset(lngCount).NumberFormatLocal = "@"
'行末にNoを書き込み
.Offset(lngCount).Value = vntTagNo
'挿入位置を返す
GetTagNoRow = lngCount
'探索範囲の更新
Set rngScope _
= .Offset(1).Resize(lngCount)
End With
End If
End Function
Private Function DataSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long, _
Optional lngMode As Long = 1) As Long
Dim vntFind As Variant
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, lngMode)
lngOver = 1
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
DataSearch = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
End If
End Function
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
If lngRows = 1 Then
ReDim vntData(1 To lngRows, 1 To 2)
vntData(lngRows, 1) = .Resize(lngRows).Value
Else
vntData = .Resize(lngRows).Value
ReDim Preserve vntData(1 To lngRows, 1 To 2)
End If
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
End If
If j > 0 Then
.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
省略
|
|
ミツコ
- 05/9/13(火) 22:48 -
