[[20090519134404]]　『CSVファイルの転記』（ryo）　ページの最後に飛ぶ

 『CSVファイルの転記』（ryo）
 いつもお世話になっています。
 DLしたCSVデータをエクセルCSVファイルとして保存しています。このファイルは行1～3 
 までは項目です。行4以降をエクセルワークシートのAファイルのC5から転記積立したい
 のですがご教授のほどよろしくお願いします。

 たとえば、こんな感じで

 Sub test()
 Dim fn As String, temp As String, x, y
 Dim a() As String, i As Long, ii As Long, maxCol As Long
 fn = "c:\temp.csv"    '<- ファイルパス　要変更
 temp = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
 x = Split(temp, vbCrLf)
 ReDim a(1 To UBound(x), 1 To 100)
 For i = 3 To UBound(x)
     y = Split(x(i), ",")
     For ii = 0 To UBound(y)
         a(i - 2, ii + 1) = y(ii)
     Next
     maxCol = Application.Max(maxCol, UBound(y) + 1)
 Next
 ThisWorkbook.Sheets(1).Cells(5, "c").Resize(UBound(x), maxCol).Value = a
 End sub
 (seiya)

 (seiya)さん　有難うございます。申し訳ありません。少し説明が足らなかったようで
 す。
 DLしたCSVデータをフォルダにエクセルCSVファイルとして保存しています。
                  --------    
 このフォルダを開いてファイルを指定して転記蓄積したいのです。
 (ryo)

 Application.GetOpenFileNameでfnにファイル名を格納すれば
 よいだけですよ？
 (seiya)

 ご親切に有難うございます。出来ました。只、少し私のやりたい事と少し違うところが
 ありますが自分で勉強してみます。もしどうしても出来ないときは又ご教授お願いしま
 す。
 (ryo)

 いつも有難うございます。2ヶ所お教え頂きたいのです。
 fn = "c:\temp.csv"→fn = Application.GetOpenFilename("カンマ区切りＣＳＶファイ
 ル,*.csv")に変更
 1.CSVファイルをエクセルに取り込んだ場合文字データの前後に　「""  ""」が入りま  
 す。
 1.CSVフォルダを開きキャンセルすると
 　実行時エラー　53　ファイルが見つかりません。
 temp = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
 にデバッグが出ます。よろしくお願いします。
 (ryo)

 > 1.CSVフォルダを開きキャンセルすると
 > 実行時エラー　53　ファイルが見つかりません。

 以下のようにする必要があります。
 fn = Application.GetOpenFilename("カンマ区切りＣＳＶファイル,*.csv")
 If fn = "False" Then
     MsgBox "ファイル選択をキャンセルしました。処理を中止します"
     Exit Sub
 End If

 (とおりすがり)

 > 1.CSVファイルをエクセルに取り込んだ場合文字データの前後に　「""  ""」が入ります。

 こんな感じかな？
 y(ii)の先頭と末尾が " だったら、除去します。

 Sub test2()
     Dim fn As String, temp As String, x, y
     Dim a() As String, i As Long, ii As Long, maxCol As Long
     ' fn = "c:\temp.csv"    '<- ファイルパス　要変更
     fn = Application.GetOpenFilename("カンマ区切りＣＳＶファイル,*.csv")
     If fn = "False" Then
         MsgBox "ファイル選択をキャンセルしました。処理を中止します"
         Exit Sub
     End If

     temp = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
     x = Split(temp, vbCrLf)
     ReDim a(1 To UBound(x), 1 To 100)
     For i = 3 To UBound(x)
         y = Split(x(i), ",")
         For ii = 0 To UBound(y)
             If Left(y(ii), 1) = """" Then
                 y(ii) = Mid(y(ii), 2)
             End If
             If Right(y(ii), 1) = """" Then
                 y(ii) = Mid(y(ii), 1, Len(y(ii)) - 1)
             End If
             a(i - 2, ii + 1) = y(ii)
         Next
         maxCol = Application.Max(maxCol, UBound(y) + 1)
     Next
     If UBound(x) > 0 And maxCol > 0 Then
         ThisWorkbook.Sheets(1).Cells(5, "c").Resize(UBound(x), maxCol).Value = a
     Else
         MsgBox "出力データなし"
     End If
 End Sub

 (とおりすがり)

 (とおりすがり)さん　有難うございます。２ヶ所とも正常に変換することが出来まし 
 た。私のスキルではこの様な難しいコードをいくら頑張ってみても訂正することは出来
 ませんでした。もっと勉強をします。
 (ryo)

 どっかで同じようなことしてたと思うけど...
 CSV で Field内にカンマがある場合にも対応
 "123,456","a,ggg,123",123,,

 Sub ReadCSV()
 Dim fn As String, temp As String, x, y, a() As String
 Dim i As Long, ii As Long, maxCol As Long
 fn = Application.GetOpenFileName("*.csv")
 If fn = "False" Then Exit Sub
 temp = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
 x = Split(temp, vbCrLf)
 ReDim a(1 To UBound(x) + 1, 1 To 200)
 For i = 0 To UBound(x)
     y = Split(CleanCSV(x(i), Chr(2), Chr(3)), ",")
     For ii = 0 To UBound(y)
         a(i + 1, ii + 1) = y(ii)
     Next
     maxCol = Application.Max(maxCol, UBound(y) + 1)
 Next
 With ThisWorkbooks.Sheets(1).Cells(1).Resize(n, maxCol)
     .Value = a
     .Replace Chr(2), ",", xlPart
     .Replace Chr(3), vbNullString, xlPart  
 End With
 End Sub

 Function CleanCSV(ByVal txt As String, ByVal subComma As String, _
                   ByVal subDQ As String) As String
 Dim m As Object
 With CreateObject("VBScript.RegExp")
     .Pattern = "(^|,)(""[^""]+"")(,|$)"
     Do While .test(txt)
         Set m = .execute(txt)(0)
         txt = Application.Replace(txt, m.firstindex + 1, m.length, m.submatches(0) & _
         Replace(Replace(m.submatches(1), ",", subComma), """", subDQ) & m.submatches(2)) '<-修正 15:12
     Loop
 End With
 CleanCSV = txt
 End Function
 (seiya)

 (seiya)さん　有難うございます。ただ
 > txt = Application.Replace(txt, m.firstindex + 1, m.length, m.submatches(0) &
  _
 Replace(Replace(m.submatches(1), ",", subComma), """", subDQ) & m.submatches(2)

 この部分で構文エラーで赤文字になります。
 （ryo)

 アンダースコア _ の位置がおかしくないですか？
 (seiya)

 Application.Replaceの閉じかっこは・・・？

 (HANA)

 >  Application.Replaceの閉じかっこは・・・？
 修正しました。
 (seiya)

 ryoさんのコードで使用するなら

      y = Split(x(i), ",")

を

      y = Split(CleanCSV(x(i), Chr(2), Chr(3)), ",")

 に変更して

     If UBound(x) > 0 And maxCol > 0 Then
         ThisWorkbook.Sheets(1).Cells(5, "c").Resize(UBound(x), maxCol).Value = a
     Else
         MsgBox "出力データなし"
     End If
 を

     If UBound(x) > 0 And maxCol > 0 Then
         With ThisWorkbook.Sheets(1).Cells(5, "c").Resize(UBound(x), maxCol)
             .Value = a
             .Replace Chr(2), ",", xlPart
             .Replace Chr(3), vbNullString, xlPart
         End With
     Else
         MsgBox "出力データなし"
     End If

 にすればできると思います。
 (seiya)

 (seiya)さん　大変ご親切に有難うございます。コードとにらみっこしていますがあまり
 に難しすぎて私には理解できません。幸いに(とおりすがり)さんのコードでうまく動い
 ていますのでこちらを採用させていただきます。
 (ryo)

コメント返信：

[ 一覧(最新更新順) ]

[[20090519134404]] 『CSVファイルの転記』（ryo） ページの最後に飛ぶ

[[20090519134404]]　『CSVファイルの転記』（ryo）　ページの最後に飛ぶ