| |
テキストファイルがCSV（カンマ区切り）のデータとした場合の読み込みです
Option Explicit
Public Sub CSVRead()
' CSVデータの読み込み
Dim i As Long
Dim rngWrite As Range
Dim lngRow As Long
Dim lngPos As Long
Dim strPath As String
Dim dfn As Integer
Dim vntFileNames As Variant
Dim vntField As Variant
Dim strBuff As String
Dim dicIndex As Object
Dim vntResult As Variant
Dim blnWrite As Boolean
Dim strProm As String
'書き込む位置を設定
Set rngWrite = ActiveSheet.Cells(1, "A")
rngWrite.Offset(, 1).EntireColumn.NumberFormatLocal = "yyyy/mm/dd"
'読み込むファイルのフォルダを設定
strPath = ThisWorkbook.Path
' strPath = "E:\Office2000\Excel\Test6\TestData"
'指定フォルダからファイル名を取得
If Not GetReadFile(vntFileNames, strPath, False) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'画面更新を停止
' Application.ScreenUpdating = False
'指定ファイルを読み込みモードでOpen
dfn = FreeFile
Open vntFileNames For Input As dfn
'ファイルエンドまで繰り返し
Do Until EOF(dfn)
'ファイルから１行読み込み
Line Input #dfn, strBuff
'CSVをフィールドに分割
vntField = SplitCsv(strBuff, ",")
'書き込みFlagをTrueに
blnWrite = True
With dicIndex
'Indexに名前の登録が有るなら
If .Exists(vntField(0)) Then
'Listの出力位置を取得
lngPos = .Item(vntField(0))
'Listから該当データを取得
vntResult = rngWrite.Offset(lngPos) _
.Resize(, UBound(vntField) + 1).Value
'もし、該当データの日付が新しいなら
If vntResult(1, 2) > DateValue(vntField(1)) Then
'書き込みFlagをFalseに
blnWrite = False
End If
Else
'最終行を書き込み位置にする
lngPos = lngRow
'Indexに名前をKeyとして出力行位置を登録
.Item(vntField(0)) = lngPos
'書き込み行位置を更新
lngRow = lngRow + 1
End If
End With
If blnWrite Then
'指定シートの指定行列位置にフィールドの書き込み
rngWrite.Offset(lngPos).Resize(, _
UBound(vntField) + 1).Value = vntField
End If
Loop
'ファイルをClose
Close #dfn
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
'Dictionaryオブジェクトを破棄
Set dicIndex = Nothing
Set rngWrite = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function SplitCsv(ByVal strLine As String, _
Optional strDelimiter As String = ",", _
Optional strQuote As String = """", _
Optional strRet As String = vbCrLf, _
Optional blnMulti As Boolean) As Variant
' strLine :分割元と成る文字列
' strDelimiter :区切り文字
' SplitCsv :戻り値、切り出された文字配列
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i As Long
Dim vntField As Variant
Dim lngLength As Long
i = 0
lngStart = 1
lngLength = Len(strLine)
blnMulti = False
Do
ReDim Preserve vntData(i)
If Mid$(strLine, lngStart, 1) <> strQuote Then
lngDPos = InStr(lngStart, strLine, _
strDelimiter, vbBinaryCompare)
If lngDPos > 0 Then
vntField = Mid$(strLine, lngStart, _
lngDPos - lngStart)
If lngDPos = lngLength Then
ReDim Preserve vntData(i + 1)
End If
lngStart = lngDPos + 1
Else
vntField = Mid$(strLine, lngStart)
lngStart = lngLength + 1
End If
Else
lngStart = lngStart + 1
Do
lngDPos = InStr(lngStart, strLine, _
strQuote, vbBinaryCompare)
If lngDPos > 0 Then
vntField = vntField & Mid$(strLine, _
lngStart, lngDPos - lngStart)
lngStart = lngDPos + 1
Select Case Mid$(strLine, lngStart, 1)
Case ""
Exit Do
Case strDelimiter
lngStart = lngStart + 1
Exit Do
Case strQuote
lngStart = lngStart + 1
vntField = vntField & strQuote
End Select
Else
blnMulti = True
vntField = Mid$(strLine, lngStart) & strRet
lngStart = lngLength + 1
Exit Do
End If
Loop
End If
vntData(i) = vntField
vntField = Empty
i = i + 1
Loop Until lngLength < lngStart
SplitCsv = vntData()
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 File (*.csv),*.csv," _
& "Text File (*.txt),*.txt," _
& "CSV and Text (*.csv; *.txt),*.csv;*.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, 1, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
Hirofumi
- 06/6/25(日) 13:33 -
