Excel VBA質問箱 IV

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

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


75919 / 76732 ←次へ | 前へ→

【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

2 hits

【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 お礼

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