エクセルVBAについて質問です。


指定したフォルダに入っている全てのCSVファイルの内容を
アクティブなエクセル内の新しいシートを左から3番目に作って
書き出すというマクロを作ってください。

手作業だと以下のような手順になります。
①フォルダ内のCSVファイルを一つずつ開いていく。
②エクセル内に新しいシートを左から3番目(sheet3)に作成。
  (注)できあがったシートは名前順に並んでるようにしてください。
③開いているCSVの内容を全部コピー。
④新しく作ったシートに貼り付ける。
⑤CSVファイルを閉じる。
⑥全てのCSVについて同じ作業を繰り返す。

以上、よろしくお願いします。

回答の条件
  • URL必須
  • 1人2回まで
  • 登録:2007/12/28 12:50:36
  • 終了:2007/12/28 17:04:34

回答(2件)

id:ku__ra__ge No.1

ku__ra__ge回答回数118ベストアンサー獲得回数402007/12/28 14:34:34

ポイント100pt

以下のコードを利用してみてください。

'Option Explicit '変数宣言強制をしない

Sub readCsv()
    Const MODE_READ = 1

    Set ShellApp = CreateObject("Shell.Application")
    Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1)
    targetFolder = oFolder.Items.Item.Path

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fileList = fso.GetFolder(targetFolder).Files

    For Each file In fileList
        Worksheets.Add Worksheets(3 + fileCounter)
        ActiveSheet.Name = file.Name
        
        Set ts = file.OpenAsTextStream(MODE_READ)
        Set pasteCell = Range("a1")
        While Not ts.AtEndOfStream
            pasteCell.Value = ts.ReadLine
            Set pasteCell = pasteCell.Offset(1, 0)
        Wend
        ts.Close
        
        fileCounter = fileCounter + 1
    Next
End Sub

http://example.com/dummy

id:taroemon

ご回答ありがとうございます。

うまくいきました。

2007/12/28 17:02:09
id:SALINGER No.2

SALINGER回答回数3430ベストアンサー獲得回数9692007/12/28 14:45:23

ポイント40pt

ようは、フォルダ内のCSVを3枚目以降に挿入するということだと思うので(違ったらすいません)

Sub Macro()
    Dim FoldPath As String
    Dim f
    Dim ch1 As Long
    Dim r As Long
    Dim textLine As String
    Dim csvLine() As String
    Dim i As Long
    Dim FSO
    
    'フォルダのパスを指定
    FoldPath = "C:\Documents and Settings\hogehoge\デスクトップ\test"
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    i = 2
    For Each f In FSO.GetFolder(FoldPath).Files
        If StrConv(Right(f.Path, 4), vbLowerCase) = ".csv" Then
            ch1 = FreeFile
            Open f.Path For Input As #ch1
            r = 1
            
            Worksheets.Add after:=Worksheets(i)
            With ActiveSheet
                .Name = Left(f.Name, Len(f.Name) - 4)
                Do While Not EOF(ch1)
                    Line Input #ch1, textLine
                    csvLine() = Split(textLine, ",")
                    .Range(Cells(r, 1), Cells(r, UBound(csvLine()) + 1)) = csvLine()
                    r = r + 1
                Loop
            End With
            i = i + 1
    
            Close #ch1
        End If
    Next
End Sub

CSVを参照渡しで表示してるので、数字が文字列として扱われますが一度保存して開けば問題ないです。

http://q.hatena.ne.jp/

id:taroemon

いつもご回答ありがとうございます。

質問の解釈は間違っていません。わかりづらい説明で失礼しました。


たぶん私の方に問題あると思うのですが、コピペしてそのまま実行すると、

「.Range(Cells(r, 1), Cells(r, UBound(csvLine()) + 1)) = csvLine()」の部分で、

アプリケーション定義もしくはオブジェクト定義のエラーです。」というエラーがでます。

2007/12/28 17:03:43
  • id:SALINGER
    CSVファイルに空白行があるとエラーになります。

    csvLine() = Split(textLine, ",")
    .Range(Cells(r, 1), Cells(r, UBound(csvLine()) + 1)) = csvLine()



    If textLine <> "" Then
    csvLine() = Split(textLine, ",")
    .Range(Cells(r, 1), Cells(r, UBound(csvLine()) + 1)) = csvLine()
    End If

    にすればいいですね。
  • id:ku__ra__ge
    うまくいったと言うことで、不要だとは思いますが細かい追記・修正です。
    回答のマクロはシートが最低3つないとエラーになるので、シートが足りない場合はダミー用の空シートなどを追加して動かすとよいです。
    また、csvファイルしかないフォルダを指定する場合は問題ないですが、指定フォルダの全ファイルを読み込むようになっているので、それを解決する場合
    For Each file In fileList
     ↓
    For Each file In fileList
    If UCase(Right(file.Name, 3)) = "CSV" Then

    Next
     ↓
    End If
    Next
    のように、変更してください。
  • id:taroemon
    お二人とも丁寧なコメントありがとうございました。
    参考人させていただきます。
    今後ともよろしくお願いします。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません