| |
アドバイスよろしくお願いします。
下のテキストデータをエクセルの表に取り込もうと思います。
並びは日付,時間,秒,0,0,ID,コード,値 です。
20050102,1000,0,0,102,00100010,111
20050102,1000,0,0,106,00100020,112
20050102,1000,0,0,104,00100030,113
20050102,1000,0,0,105,00100040,114
20050102,1000,0,0,101,00100050,11
20050102,1000,0,0,108,00100120,122
20050102,1000,0,0,101,00100130,123
20050102,1000,0,0,103,00100140,124
20050102,1000,0,0,101,00100150,125
以下500行程続く
エクセルの表は↓になります。Ｃセルに上記データの値を入力
セル Ａ Ｂ Ｃ
5 登録 巡回 値
6 コード 名称 20050102
7 00100010 Ａ
8 00100020 Ｂ
9 00100030 Ｃ
10 00100040 Ｄ
11 00100050 Ｅ
12 00100120 Ｆ
13 00100130 Ｇ
過去の質問を参考に下記マクロを試しました。
---------------------------------------------------
Option Explicit
Public Sub メーター()
Dim vntFileName 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 blnWayOut As Boolean
'「ファイルを開く」ダイアログを表示
If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
Exit Sub
End If
Application.ScreenUpdating = False
'ActiveSheetのA1セルを基準とする（Listの左上隅）
Set rngResult = ActiveSheet.Cells(6, "A")
With rngResult
'日付の書かれている列数を取得
lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
'日付の有る範囲を取得
If lngCol = 0 Then
blnWayOut = True
GoTo WayOut
End If
'日付列の範囲を取得
Set rngDate = .Offset(, 1).Resize(, lngCol)
'タグNo.が有る範囲を取得
Set rngScope = Range(.Offset(1), .Offset(65536 - .Row).End(xlUp))
End With
'指定されたファイルをOpen
dfn = FreeFile
Open vntFileName For Input As dfn
'ファイルから日付を取得
Do Until EOF(dfn)
'ファイルから１行読み込み
Line Input #dfn, strBuff
'フィールドに分割
vntField = Split(strBuff, ",", , vbBinaryCompare)
'日付を探索
lngCol = GetDateColumn(vntField(0), rngDate, rngResult)
'タグNo.を探索
lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
'日付、TagNoの交差するセルに値を書き込み
rngResult.Offset(lngRow, lngCol).Value = vntField(6)
Loop
Close #dfn
WayOut:
Set rngScope = Nothing
Set rngDate = Nothing
Set rngResult = Nothing
Application.ScreenUpdating = True
Beep
If blnWayOut Then
MsgBox "該当する日付の列が有りません"
Else
MsgBox "処理が完了しました"
End If
End Sub
Private Function GetDateColumn(vntDate As Variant, _
rngScope As Range, _
rngListTop As Range) As Long
Dim lngFound As Long
Dim lngOver As Long
'セル値が数値として入力されている場合
lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
'セル値が文字列として入力されている場合
' lngFound = DataSearch(vntDate, rngScope, lngOver)
'日付が見つかった場合
If lngFound > 0 Then
'位置を返す
GetDateColumn = lngFound
Else
With rngListTop
'日付が最終列の以内の場合
If lngOver <= rngScope.Columns.Count Then
'指定位置に列を挿入
.Offset(, lngOver).EntireColumn.Insert
End If
'日付を書き込み
.Offset(, lngOver).Value = vntDate
'挿入位置を返す
GetDateColumn = lngOver
'日付列の範囲を更新
Set rngScope _
= .Offset(, 1).Resize(, rngScope.Columns.Count + 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 lngOver As Long
lngFound = DataSearch(vntTagNo, rngScope, lngOver)
If lngFound > 0 Then
GetTagNoRow = lngFound + 1
Else
With rngListTop.Offset(1)
If lngOver <= rngScope.Rows.Count Then
.Offset(lngOver).EntireRow.Insert
End If
.Offset(lngOver).Value = vntTagNo
GetTagNoRow = lngOver + 1
Set rngScope _
= .Offset(1).Resize(rngScope.Rows.Count + 1)
End With
End If
End Function
Private Function DataSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long) As Long
Dim vntFind As Variant
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, 1)
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 Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean = False) As Boolean
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
& "Text File (*.txt),*.txt," _
& "CSV File (*.csv),*.csv," _
& "全て (*.*),*.*"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames & "{TAB}", False
End If
'「ファイルを開く」ダイアログを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
---------------------------------------------------
しかし下記のように日付直下に値が入らず、一段づつ下へズレて入力されます。
何が悪いのでしょうか？
セル Ａ Ｂ Ｃ
5 登録 巡回 値
6 コード 名称 20050102
7 00100010 Ａ
8 00100020 Ｂ 111
9 00100030 Ｃ 112
10 00100040 Ｄ 113
11 00100050 Ｅ 114
12 00100120 Ｆ 11
13 00100130 Ｇ 122
14 00100140 Ｈ 123
124
|
|
kitty
- 05/1/17(月) 23:53 -
