Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


13457 / 13644 ツリー ←次へ | 前へ→

【4512】ファイルを複数選択して開く時の対処 ntomo 03/3/25(火) 11:39 質問
【4516】Re:ファイルを複数選択して開く時の対処 Jaka 03/3/25(火) 15:20 回答
【4517】消し忘れ Jaka 03/3/25(火) 15:29 発言
【4518】Re:ファイルを複数選択して開く時の対処 ntomo 03/3/25(火) 15:48 お礼
【4520】Re:ファイルを複数選択して開く時の対処 Jaka 03/3/25(火) 16:25 回答
【4526】Re:ファイルを複数選択して開く時の対処 ntomo 03/3/25(火) 17:03 お礼
【5244】今ごろ見つかったバグ? Jaka 03/4/30(水) 13:10 発言
【5312】Re:今ごろ見つかったバグ? ntomo 03/5/6(火) 15:20 お礼

【4512】ファイルを複数選択して開く時の対処
質問  ntomo  - 03/3/25(火) 11:39 -

引用なし
パスワード
   こんにちは
GetOpenFilenameを用いて複数のファイル(CSVファイル)を開いてその開いたファイルに
対して処理を行っているのですが、

GetOpenFilename実行時にファイル選択ウインドウにて、
開くファイルを選択したときに、右クリックにて開くをした際に
1つのファイルのみ選択しているときは正常に処理を終えるのですが、
2つ以上のファイルを選択していると処理がとまってしまいます。
右クリックをできないようにするという手もあるかとは思いますが、
右クリックでも処理が正常にすすむようにしたいなぁと思っています。
どうかいい知恵があったら教えてください。

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
  For i = 1 To UBound(vFileName)
    Workbooks.Open FileName:=vFileName(i) '←ここで処理が完了しているよう
                          'です。
    iFileName = ActiveSheet.Name

'データ処理
    Windows("test.xls").Activate
    Sheets("ワーク").Select
    ActiveCell.FormulaR1C1 = iFileName 'ファイル名をA列に記述
    ActiveCell.Offset(1, 0).Range("A1").Select

'(データ量が多すぎ、'データ処理以前で処理が中止されるので以後の処理を割愛)

  Windows(iFileName & ".csv").Activate
  ActiveWindow.Close
  Next i
  MsgBox "ファイル数:" & UBound(vFileName) & "個 が選択されました。"
End Sub

【4516】Re:ファイルを複数選択して開く時の対処
回答  Jaka  - 03/3/25(火) 15:20 -

引用なし
パスワード
   こんにちは。

>Workbooks.Open FileName:=vFileName(i) '←ここで処理が完了しているようです。
と言うよりWorkbooks.Openで、CSVファイルを開いた時のめちゃくちゃ遅い処理の性じゃないかと...。
2000だったらクエリで開いちゃう方法もありますが、CSVをTxtにかえて読み込む方法を...。
因に、OpenTextですべて文字列として読み込む方法の方が速くて良いんですが、それじゃ嫌だという人もいて...。

最後に、CSVファイルの1行目を読み込んで、この列は文字列、この列は標準と言った判断をして開いているんですが、この辺りの判断が人によってまちまちな読み込み方をするので、私の好き勝手な方法で判断しています。
尚、こう言うところは文字列で、こう言うところは標準で読み込みたいです。と言われてもどうやって作ったんだか覚えていないので、直すのにメチャクチャ時間が掛かると思う。
確か、ロジックを考えるのが嫌でステップ実行して、つど付け足したり修正していったんだと思う。

違ってたらごめんなさい。


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

【4517】消し忘れ
発言  Jaka  - 03/3/25(火) 15:29 -

引用なし
パスワード
   >    If I = 518 Then
>      hy = 0
>    End If

これ、ごちゃごちゃやっていた時の残りですので、消してください。

【4518】Re:ファイルを複数選択して開く時の対処
お礼  ntomo  - 03/3/25(火) 15:48 -

引用なし
パスワード
   ▼Jaka さん:いつもありがとうございます

>>Workbooks.Open FileName:=vFileName(i) '←ここで処理が完了しているようです。
>と言うよりWorkbooks.Openで、CSVファイルを開いた時のめちゃくちゃ遅い処理の性じゃないかと...。

ん〜まったく同じファイルを選択してから
きちんと開くボタンを押すと最後まで通るんですよ・・・
右クリックの開くの時だけなんですよね・・・・
(選択してエンターでもちゃんと通ります)


※確かに普通に開いた時もファイルを開く処理は体感で遅いんですけどね・・・・
 (でもちゃんと処理が動くんですよ。。。)

下のソースはこれから見て実行させてみます。
(よくわからないので一つ一つ見てから実行していくので時間がかかりそう・・・)
とりあえずお礼まで。

【4520】Re:ファイルを複数選択して開く時の対処
回答  Jaka  - 03/3/25(火) 16:25 -

引用なし
パスワード
   >右クリックの開くの時だけなんですよね・・・・
>(選択してエンターでもちゃんと通ります)

すみません。
見落していました。
なんか終了していると言うより、変な風に落ちちゃっている感じもしました。
んで、姑息にDoEventsを2つかましてみたら何とか走ってくれるみたいです。(3つ選択までしか試していませんが。)
何となくバクくさかったです。

DoEvents
DoEvents
Workbooks.OpenText FileName:=VFN, _
     DataType:=xlDelimited, Comma:=True, FieldInfo:=myFieldInfo

【4526】Re:ファイルを複数選択して開く時の対処
お礼  ntomo  - 03/3/25(火) 17:03 -

引用なし
パスワード
   ▼Jaka さん:速レスありがとうございます。(感謝!!

>んで、姑息にDoEventsを2つかましてみたら何とか走ってくれるみたいです。(3つ選択までしか試していませんが。)

もともとのPGの方にDoEvents挿入したら通りました。
DoEventsは1つ挿入すれば大丈夫みたいです。
(4つ選択までしか試してませんがw)

さっきのソースまだ見てる最中です・・・・(遅
続けてがんばります・・・。

【5244】今ごろ見つかったバグ?
発言  Jaka  - 03/4/30(水) 13:10 -

引用なし
パスワード
   こんにちは。
テキストオープンにちょっとバグみたいなのがあったんで、修正しておきました。
(私が気づかないだけで、他にもあるかもしんないけど...。)

テキストデータの最後が数字じゃないと実行エラーになる、バグ??。
例えば
ああああ,いいいい,うううう
かかかか,きききき,くくくく
            ↑
           ここ
 
ああああ,いいいい,"うううう"
とか、
ああああ,いいいい,12345
のだったら問題は無いんだけど..。
私の言い分としては、文字列は""でくくっとけ、ってことでした。

それと、\、$にも対応させたんだけど、2000にはバグがあって、2000SR-1では$が\に勝手に変えられちゃいます。
ただの2000だと、逆だっだと様な...。
97SR-2では、ちゃんと読み込まれます。
エクセル2000での¥$のバグの多さは、日本たたき?
自己満足と言う事で載せました。


Sub TE71()
  Dim ReadData As String, myFieldInfo(), I As Long, CNT As Integer
  Dim OpenFile As String, CommaCnt As Integer, WQoFlg As Integer
  Dim FTypTB() As Integer, MojFlg As Integer
  Dim StMsg As String, FieldData As String
  
  OpenFile = Application.GetOpenFilename("ファイル (*.txt), *.txt")
  If OpenFile = "False" Then
    End
  End If

  STime = Now()
  Open OpenFile 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 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(FieldData) = True And _
       (InStr(1, FieldData, "-") > 0 Or InStr(1, FieldData, ",") > 0))) Or _
       (Left(FieldData, 1) = "\" Or Left(FieldData, 1) = "$") And _
        IsNumeric(Mid(FieldData, 2)) Then
       FTypTB(CNT) = 1
       '↑ ExcelVBAのバグのため\記号は、文字として扱われる為、無意味だけど一応入れる。by2000SR1
       '注)$は、\に変換されてしまう。手動にて文字形式の変更が必要。by2000SR1
      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)
      'ここ、最後の文字が数字意外だとエラーになるのを修正。追加しただけだけど。
      If Len(ReadData) = I Then
       CNT = CNT + 1
       ReDim Preserve FTypTB(1 To CNT)
       FTypTB(CNT) = 2
      End If
    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)) Or _
       (Left(FieldData, 1) = "\" Or Left(FieldData, 1) = "$") And _
         IsNumeric(Mid(FieldData, 2)) Then
       FTypTB(CNT) = 1
       '↑ ExcelVBAのバグのため\記号は、文字として扱われる為、無意味だけど一応入れる。by2000SR1
       '注)$は、\に変換されてしまう。手動にて文字形式の変更が必要。by2000SR1
      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
    myFieldInfo(I) = Array(I, FTypTB(I))
  Next
  Workbooks.OpenText FileName:=OpenFile, _
       DataType:=xlDelimited, Comma:=True, FieldInfo:=myFieldInfo
  Erase FTypTB
  Erase myFieldInfo
  MsgBox "処理時間 " & Format(Now - STime, "hh:mm:ss")
  End
End Sub

【5312】Re:今ごろ見つかったバグ?
お礼  ntomo  - 03/5/6(火) 15:20 -

引用なし
パスワード
   ▼Jaka さん:いつもありがとうございます
なんかとってもびっくりでした・・・。
同日にお礼を書こうとして送信したら・・・。

GWのせいで社内LANが落とされて・・・(しかも時間より4時間はやかった・・・)

なのでお礼が遅れてすみませんでした
ちょっとGWあけでばたばたしてて忙しいので落ち着いたらみますね^^

本当にありがとうございました^^
こんな昔のものまで^^

13457 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free