| |
こんにちは。
>Workbooks.Open FileName:=vFileName(i) '←ここで処理が完了しているようです。
と言うよりWorkbooks.Openで、CSVファイルを開いた時のめちゃくちゃ遅い処理の性じゃないかと．．．。
2000だったらクエリで開いちゃう方法もありますが、CSVをTxtにかえて読み込む方法を．．．。
因に、OpenTextですべて文字列として読み込む方法の方が速くて良いんですが、それじゃ嫌だという人もいて．．．。
最後に、CSVファイルの１行目を読み込んで、この列は文字列、この列は標準と言った判断をして開いているんですが、この辺りの判断が人によってまちまちな読み込み方をするので、私の好き勝手な方法で判断しています。
尚、こう言うところは文字列で、こう言うところは標準で読み込みたいです。と言われてもどうやって作ったんだか覚えていないので、直すのにメチャクチャ時間が掛かると思う。
確か、ロジックを考えるのが嫌でステップ実行して、つど付け足したり修正していったんだと思う。
違ってたらごめんなさい。
Sub test()
Dim vFileName As Variant
Dim sDefaultPath As String, iFileName As String
'デフォルトパスの設定（必要に応じて）
sDefaultPath = "C:\"
ChDrive sDefaultPath
ChDir sDefaultPath
'Excelファイル名の入力(複数選択)
vFileName = Application.GetOpenFilename( _
fileFilter:=StrConv("CSV ﾌｧｲﾙ (*.CSV),*.x*," & _
"すべてのファイル (*.*),*.*", vbNarrow), filterIndex:=1, _
MultiSelect:=True)
'キャンセルされたかチェック（キャンセル時MSG出力）
If VarType(vFileName) = 11 Then
MsgBox "キャンセルされました。"
Exit Sub
End If
'複数ファイル選択
Dim I As Integer
Dim MSG As String
tti = LBound(vFileName)
For I = 1 To UBound(vFileName)
'Workbooks.Open FileName:=vFileName(I) '←ここで処理が完了しているよう
'です。
iFileName = Left(Dir(vFileName(I)), Len(Dir(vFileName(I))) - 4)
TxtN = Left(vFileName(I), Len(vFileName(I)) - 3) & "txt"
Name vFileName(I) As TxtN
CSVOpen (TxtN)
'データ処理
G = G + 1
Workbooks("test.xls").Sheets("ワーク").Range("A" & G).FormulaR1C1 = iFileName 'ファイル名をA列に記述
'（データ量が多すぎ、'データ処理以前で処理が中止されるので以後の処理を割愛）
Workbooks(Dir(TxtN)).Close
Name TxtN As Left(TxtN, Len(TxtN) - 3) & "csv"
Next I
MsgBox "ファイル数：" & UBound(vFileName) & "個 が選択されました。"
End Sub
Sub CSVOpen(VFN)
Dim ReadData As String, myFieldInfo(), I As Long, CNT As Integer
Dim CommaCnt As Integer, WQoFlg As Integer
Dim FTypTB() As Integer, CSVFlg As Boolean, MojFlg As Integer
Dim StMsg As String, FieldData As String
Open VFN For Input As #1
Line Input #1, ReadData
Close #1
CNT = 0: WQoFlg = 0: MojFlg = 0: FieldData = Empty
For I = 1 To Len(ReadData)
If I = 518 Then
hy = 0
End If
If Mid(ReadData, I, 1) = "," And (WQoFlg = 0 Or WQoFlg = 2) Then
CNT = CNT + 1
CommaCnt = CommaCnt + 1
ReDim Preserve FTypTB(1 To CNT)
If MojFlg = 0 And WQoFlg = 0 Or (IsNumeric(fileddata) = True And _
(InStr(1, FieldData, "-") > 0 Or InStr(1, FieldData, ",") > 0)) Then
FTypTB(CNT) = 1
Else
FTypTB(CNT) = 2
End If
FieldData = Empty
MojFlg = 0
WQoFlg = 0
ElseIf Mid(ReadData, I, 1) = Chr(34) And WQoFlg = 0 Then
WQoFlg = 1
ElseIf Mid(ReadData, I, 1) = Chr(34) And WQoFlg = 1 Then
WQoFlg = 2
If I = Len(ReadData) Then
CNT = CNT + 1
ReDim Preserve FTypTB(1 To CNT)
FTypTB(CNT) = 2
End If
ElseIf Mid(ReadData, I, 1) = "," And WQoFlg = 2 Then
WQoFlg = 0
MojFlg = 0
CommaCnt = CommaCnt + 1
ElseIf IsNumeric(Mid(ReadData, I, 1)) = False Then
MojFlg = 1
FieldData = FieldData & Mid(ReadData, I, 1)
ElseIf I = Len(ReadData) And (MojFlg = 1 Or IsNumeric(Mid(ReadData, I, 1)) = False) Then
CNT = CNT + 1
ReDim Preserve FTypTB(1 To CNT)
If IsNumeric(FieldData) = True And _
(InStr(1, FieldData, "-") > 0 Or InStr(1, FieldData, ",") > 0) Then
FTypTB(CNT) = 1
Else
FTypTB(CNT) = 2
End If
FieldData = Empty
MojFlg = 0
ElseIf I = Len(ReadData) Then
CNT = CNT + 1
ReDim Preserve FTypTB(1 To CNT)
FTypTB(CNT) = 1
MojFlg = 0
ElseIf Mid(ReadData, I, 1) <> Chr(34) Then
FieldData = FieldData & Mid(ReadData, I, 1)
End If
Next
ReDim myFieldInfo(1 To CommaCnt + 1)
For I = 1 To CommaCnt + 1
If FTypTB(I) = 1 Then
myFieldInfo(I) = Array(I, FTypTB(I))
Else
myFieldInfo(I) = Array(I, FTypTB(I))
End If
Next
Workbooks.OpenText FileName:=VFN, _
DataType:=xlDelimited, Comma:=True, FieldInfo:=myFieldInfo
Erase FTypTB
Erase myFieldInfo
End Sub
|
|
Jaka
- 03/3/25(火) 15:20 -
