| |
▼Hirofumi さん：
Hirofumiさんご返事が遅くなり申し訳ございません
早速試してみます。ありがとうございました。すごいですね〜！
>テキストファイルが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
|
|
kaoru
- 06/6/26(月) 20:01 -
