| |
かみちゃん様、Hirofumi様 ありがとうございます。
動作確認をさせて頂きました。
過去の検索をし、Hirofumi様の外部データの取り込みマクロを
改造してみました。
ダイアログを表示させてファイルを選択すれば動作します。
これに今回ご提示頂いたマクロを組み込み、ダイアログによる選択を無くすには
どのようにすればよいかが分かりません。
ご指導をお願い致します。
Public Sub データ表示()
'日付の先頭位置の前の列
Const clngTop As Long = 13
Dim strPath As String
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 strProm As String
Dim strNoMatch As String
Dim A As String
'Textファイルの有るフォルダを指定
strPath = "C:\list"
'「ファイルを開く」ダイアログを表示
If Not GetReadFile(vntFileName, strPath, False) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
Application.ScreenUpdating = False
'ActiveSheetのA1セルを基準とする
Set rngResult = Worksheets("フォーマット").Cells(8, "A")
With rngResult
'日付の書かれている列数を取得
lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
- .Offset(, clngTop).Column
'日付列の範囲を取得
If lngCol > 0 Then
Set rngDate = .Offset(, clngTop + 1).Resize(, lngCol)
Else
strProm = "日付列が有りません。"
GoTo Wayout
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
'指定されたファイルをOpen
dfn = FreeFile
Open vntFileName 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)))
'No.を探索
lngRow = GetTagNoRow(vntField(4), rngScope, rngResult)
'行位置が見つかったら
If lngRow > 0 Then
'日付を探索
lngCol = GetDateColumn(vntField(0), rngDate, _
rngResult.Offset(, clngTop)) + clngTop
If lngCol = 0 + clngTop Then
'該当日付が無い場合、メセージを出し直ちに終了する
strProm = Format(vntField(0), "m/d") & " の日付が有りません。"
GoTo Wayout
End If
'日付、Noの交差するセルに値を書き込み
With rngResult.Offset(lngRow, lngCol)
.NumberFormatLocal = "G/標準"
.Value = vntField(5)
End With
A = vntField(1)
rngResult.Offset(2, lngCol).Value = Left(A, 2) & "：" & Right(A, 2)
End If
Loop
If strNoMatch = "" Then
strProm = "処理が完了しました"
Else
strProm = "以下の該当しない日付がファイルに存在します" & vbCrLf & strNoMatch
End If
Wayout:
Close #dfn
Application.ScreenUpdating = True
Set rngScope = Nothing
Set rngDate = Nothing
Set rngResult = Nothing
Beep
MsgBox strProm
End Sub
Private Function GetDateColumn(vntDate As Variant, _
rngScope As Range, _
rngDateTop As Range) As Long
Dim lngFound As Long
'日付範囲に日付が無いなら
If rngScope Is Nothing Then
lngFound = 0
Else
'日付の探索
'セル値が数値として入力されている場合
lngFound = DataSearch(CLng(vntDate), rngScope)
'セル値が文字列として入力されている場合
' lngFound = DateSearch(vntDate, rngScope)
End If
GetDateColumn = lngFound
End Function
Private Function GetTagNoRow(vntTagNo As Variant, _
rngScope As Range, _
rngListTop As Range) As Long
Dim lngFound As Variant
'No範囲にNoが無いなら
If rngScope Is Nothing Then
lngFound = 0
Else
'Noを探索
lngFound = DataSearch(CLng(vntTagNo), rngScope, , 0)
End If
'位置を返す
GetTagNoRow = lngFound
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 Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean _
= False) As Boolean
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "Text File (*.txt),*.txt,"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames & "{TAB}", False
End If
'「ファイルを開く」ダイアログを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 2, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
みり
- 06/1/4(水) 16:20 -
