| |
>これを回避する方法はあるのでしょうか...
>ご教授いただければ幸いです。
お役に立てなくて申し訳有りませんが、
私はBookとしてファイルを開く事を余りしないので、
直接、この件の解決策を提示できません
しかし、Bookとしてファイルを開くではなく、シートに直接読み込むなら以下の様な
コードで読めると思います
尚、このコードで読み込む場合、処理速度は期待しないで下さい
かなり遅いと思います
また、提示のコードは、アクティブシートのA列１行から書き込みます
書き込むシートを指定したい場合は、「書き込むシートの参照を設定」のActiveSheet
と成っている所を変更して下さい
また、「書き込む先頭行の初期値」と「書き込む先頭列の初期値」を変更すれば、
書き込む行列が変更できます
また、「vntFieldInfo = Array(」の所はOpenTextのFieldInfoと同じ設定方式にした積もりです
以下を同一の標準モジュールに記述して下さい
Option Explicit
Public Sub ReadCsv()
Dim i As Long
Dim vntFileName As Variant
Dim vntFieldInfo As Variant
Dim lngWriteRow As Long
Dim lngWriteCol As Long
Dim wksWrite As Worksheet
Dim strPath As String
'読み込むファイル名を取得
' vntFileName = "CSVFILE"
' strPath = "C:\work"
vntFileName = "CSVTest1"
strPath = ThisWorkbook.Path
If Not GetReadFile(vntFileName, strPath) Then
Exit Sub
End If
' Application.ScreenUpdating = False
'書き込む先頭行の初期値
lngWriteRow = 1
'書き込む先頭列の初期値
lngWriteCol = 1
'書き込むシートの参照を設定
Set wksWrite = ActiveSheet
'FieldInfoを設定（OpenTextのFieldInfoと同じ？）
vntFieldInfo = Array(Array(1, 2), Array(2, 2), Array(3, 2), _
Array(16, 2), Array(17, 2), Array(18, 2), _
Array(31, 2), Array(32, 2), Array(33, 2), _
Array(46, 2), Array(47, 2), Array(48, 2), _
Array(61, 2), Array(62, 2), Array(63, 2), _
Array(76, 2), Array(77, 2), Array(78, 2), _
Array(91, 2), Array(92, 2), Array(93, 2))
'セルの書式を設定
CellsFormat vntFileName, wksWrite, vntFieldInfo, _
lngWriteRow, lngWriteCol
'シートに読み込み
CSVReadSeq vntFileName, wksWrite, _
lngWriteRow, lngWriteCol, True, ","
Set wksWrite = Nothing
' Application.ScreenUpdating = True
End Sub
Private Sub CSVReadSeq(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 = ",")
Dim dfn As Integer
Dim vntField As Variant
Dim strLine As String
Dim blnMulti As Boolean
Dim strRec As String
'空きファイル番号を取得
dfn = FreeFile
'ファイルをInputモードでOpen
Open strFileName For Input As dfn
'ファイルEndまで繰り返し
Do Until EOF(dfn)
'１レコード読み込む
Line Input #dfn, strLine
'論理レコードに物理レコードを加算
strRec = strRec & strLine
'レコードをフィールドに分割
vntField = SplitLine(strRec, strDelim, , , blnMulti)
'もし、１論理レコードが複数行に渡るなら
If blnMulti Then
'論理レコードにLfを付加
strRec = strRec & vbLf
Else
If blnHeader Then
'書き込みシートの指定行列を先頭として
With wksWrite.Cells(lngRow, lngCol)
'１レコード文のフィールを書き込み
.Offset.Resize(, UBound(vntField) + 1) = vntField
End With
'書き込み行を更新
lngRow = lngRow + 1
End If
strRec = ""
blnHeader = True
End If
Loop
Close #dfn
End Sub
Private Sub CellsFormat(ByVal strFileName As String, _
ByVal wksWrite As Worksheet, _
vntFieldAtt As Variant, _
Optional ByVal lngRow As Long = 1, _
Optional ByVal lngCol As Long = 1)
' セルの書式設定
Dim i As Long
Dim dfn As Integer
Dim lngRowCount As Long
Dim strBuff As String
Dim lngFormatCol As Long
'空きファイル番号を取得
dfn = FreeFile
'ファイルをOpen
Open strFileName For Input As dfn
lngRowCount = 0
Do Until EOF(dfn)
Line Input #dfn, strBuff
'行数を取得
lngRowCount = lngRowCount + 1
Loop
'ファイルをClose
Close #dfn
'指定シートに就いて
With wksWrite
'FieldInfo全てに就いて繰り返し
For i = 0 To UBound(vntFieldAtt, 1)
'設定列を設定
lngFormatCol = vntFieldAtt(i)(0) - 1
'設定列の列の範囲を設定
With .Cells(lngRow, lngCol + lngFormatCol)
With Range(.Offset(), _
.Offset(lngRow + lngRowCount - 2))
'FieldInfoに従い書式を設定
Select Case vntFieldAtt(i)(1)
Case 1
.NumberFormatLocal = "G/標準"
Case 2
.NumberFormatLocal = "@"
Case 5
.NumberFormatLocal = "yyyy/mm/dd"
End Select
End With
End With
Next i
End With
End Sub
Private Function SplitLine(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 :区切り文字
' SplitLine :戻り値、切り出された文字配列
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i As Long
Dim vntField As String
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)
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 = ""
i = i + 1
Loop Until lngLength <= lngStart
SplitLine = vntData()
End Function
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean = False) As Boolean
Dim i As Long
Dim strFilter As String
'フィルタ文字列を作成
For i = 1 To 4
strFilter = strFilter & Choose(i, "CSV File (*.csv),*.csv,", _
"Text File (*.txt),*.txt,", _
"CSV and Text (*.csv; *.txt),*.csv;*.txt,", _
"全て (*.*),*.*")
Next i
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames, False
End If
vntFileNames _
= Application.GetOpenFilename(strFilter, 2, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
- 03/9/27(土) 16:55 -
