| |
でっかいCSVを良く使用するのですが、素直に(ダブルクリック)Excelで開くとやたらと時間がかかります。ものによっては30分以上。
(セルの書式設定→折り返して全体を表示する がデフォルトでONなので、折り返し計算をしているようです。)
Accessに入れてみたり、ODBCに入れてみたりしてだましだまし運用しているのですが、どちらも微妙な制限が付きまとうので、
Open x For Binary As y で読む方法を検討中です。
しかし、コーディングしてみたところ遅いです。
（推測ですが、Nバイト目でなくN文字目と見てるので、でかくなるとやたらと時間かかるんですかね。)
速くする方法があれば御教示下さい。(読みにくくしてまで細かいところを削るつもりはありません。)
尚、CSVの書式は下記のようです。
・カンマでデータを区切っている。
・ダブルクォーテーション内に改行が有りうる。改行コードは複数種類有り得る様子。(CR,LF,CRLF)
・ダブルクォーテーションの中は任意の文字が入る。
・ダブルクォーテーション内のダブルクォーテーションはダブルクォーテーション2つ
・ダブルクォーテーション内のカンマは唯のカンマ
・日付のデータがある。(現状↓のコードを実行すると一部変な結果になる。dd/mm/yy等と認識されてるっぽい)
-------------------------------------
Option Explicit
Sub CSVtoExcel()
Const CDEFAULTFILE = "test.csv"
Dim buff() As Byte
Dim FNo As Long
Dim iLen As Long
Dim sUTF As String
Dim i As Long
Dim sPath As String
Dim rCur As Range
Dim s As String
Dim sCell As String
Dim wsOut As Worksheet
Dim iFrom As Long
Dim iLimit As Long
' お約束
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' ファイル名決定
sPath = ThisWorkbook.Path & "\" & CDEFAULTFILE
If MsgBox(sPath & "を変換しますか？", vbYesNo, "ファイル選択") = vbNo Then
ChDrive Left(ThisWorkbook.Path, 2)
ChDir ThisWorkbook.Path
sPath = Application.GetOpenFilename("CSV ファイル (*.csv), *.csv")
If sPath = "False" Then
MsgBox ("キャンセルしました")
Exit Sub
End If
End If
' 初期化
Set wsOut = Sheet1
sCell = ""
Set rCur = wsOut.Cells(1, 1)
wsOut.Cells.Clear
wsOut.Cells.WrapText = False
wsOut.Cells.RowHeight = 13 ' 意地でも折り返ししない
iLen = FileLen(sPath)
ReDim buff(iLen)
' ファイルを読み込む
FNo = FreeFile()
Open sPath For Binary As #FNo
Get #FNo, , buff
Close #FNo
sUTF = StrConv(buff, vbUnicode)
iLen = Len(sUTF)
For i = 1 To iLen
s = Mid(sUTF, i, 1)
Select Case s
Case """"
iFrom = i + 1
iLimit = iFrom
Do
iLimit = InStr(iLimit, sUTF, """")
If Mid(sUTF, iLimit + 1, 1) = """" Then
sCell = sCell & Mid(sUTF, iFrom, iLimit - iFrom + 1)
iFrom = iLimit + 2
iLimit = iFrom
Else
sCell = sCell & Mid(sUTF, iFrom, iLimit - iFrom)
i = iLimit
Exit Do
End If
Loop
Case vbCr, vbCrLf, vbLf
writeCell rCur, sCell
Set rCur = rCur.Worksheet.Cells(rCur.Row + 1, 1)
' CRLFは改行一個 (cr とか lfの扱い自信無い。)
If s = vbCr And Mid(sUTF, i + 1, 1) = vbLf Then
i = i + 1
End If
Case ","
writeCell rCur, sCell
Set rCur = rCur.Offset(0, 1)
Case Else
sCell = sCell & s
End Select
Next
writeCell rCur, sCell
wsOut.Cells.WrapText = False
wsOut.Cells.RowHeight = 13.5
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "完了"
End Sub
Function writeCell(ByRef r As Range, ByRef s As String)
If Left(s, 1) = "-" Or Left(s, 1) = "−" Then
s = "'" & s
End If
r.Value = s
s = ""
End Function
|
|
りった
- 08/12/9(火) 17:08 -
