| |
もし、HeaderとDataの間にCrlf以外の改行コードが有るとしたら
Crの場合、Openステートメントが改行と見なすので、
Lfが改行コードに成って居るのでは？
だとすると、FileSystemObjectで読めるのでは？
Option Explicit
Public Sub ReadCsvFSO()
Dim i As Long
Dim vntFileName As Variant
Dim wksResult As Range
Dim lngRow As Long
Dim lngColumn As Long
Dim strProm As String
'読み込むファイルを指定
If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
strProm = "読み込みがキャンセルされました"
GoTo Wayout
End If
'画面更新を停止
Application.ScreenUpdating = False
'書き込むシートを設定
Set wksResult = ActiveSheet
'書き込み始める行位置を設定
lngRow = 1
'書き込み始める列位置を設定
lngColumn = 1
'読み込みファイルのデータをシートに出力
'第１引数 読み込みファイル名
'第２引数 書き込むシート
'第３引数 書き込み始める行位置
'第４引数 書き込み始める列位置
CSVReadFSO vntFileName, wksResult, lngRow, lngColumn, True, ","
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set wksResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub CSVReadFSO(ByVal strFileName As String, _
ByVal wksWrite As Worksheet, _
Optional ByRef lngRow As Long = 1, _
Optional ByRef lngCol As Long = 1, _
Optional ByRef blnHeader As Boolean = True, _
Optional strDelim As String = ",")
' CSVデータの読み込み
Dim vntField As Variant
Dim strLine As String
Dim blnMulti As Boolean
Dim strRec As String
Dim objFso As Object
Dim objFileStr As Object
Const ForReading = 1
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'指定ファイルを読み込みモードでOpen
Set objFileStr = objFso.OpenTextFile(strFileName, ForReading)
With objFileStr
Do Until .AtEndOfStream
'ファイルから１行読み込み
strLine = .ReadLine
'読み込み行を論理レコードに追加
strRec = strRec & strLine
'CSVをフィールドに分割
vntField = SplitCsv(strRec, strDelim, , , blnMulti)
'もし、論理レコードに成らない場合
If blnMulti Then
'論理レコードにLfを追加
strRec = strRec & vbLf
Else
If blnHeader Then
'指定シートの指定行列位置について
With wksWrite.Cells(lngRow, lngCol)
'フィールドの書き込み
.Resize(, UBound(vntField) + 1).Value = vntField
End With
'書き込み行位置を更新
lngRow = lngRow + 1
End If
'論理レコードを初期化
strRec = ""
blnHeader = True
End If
Loop
'ファイルをClose
.Close
End With
Set objFileStr = Nothing
Set objFso = Nothing
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
- 05/11/4(金) 23:23 -
