質問です。

A列       B列  ~   P列
ユーザID    コード
111111   3A1BEW
222222   3A280W
333333   3A3XWZ
以上のようなデータのCSVファイルがあります。1行目は項目、2行目からデータ(1グループ2万件位)、列はA列からP列まであります。B列のコード項目をグループごとに別ファイルにコード名でファイルを自動的につくり、そこに項目AからPまでとそのグループごとのデータをコピーして収納できるマクロができますか。
ファイル名が3A1BEWで項目とグループのデータ
ユーザID    コード
111111   3A1BEW

ファイル名が3A280Wで項目とグループのデータ
ユーザID    コード
222222   3A280W

ファイル名が3A3XWZで項目とグループのデータ
ユーザID    コード
333333   3A3XWZ

よろしくおねがいします。

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/05/12 12:42:18
  • 終了:2011/05/13 09:43:38

ベストアンサー

id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/05/12 14:30:23

ポイント50pt

指定したフォルダ内にある csvのファイルを一括して処理します。

Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。

p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "csv")

End Sub


Sub jikkou(p As String, s As String)

Dim bk_name As Workbook
Application.DisplayAlerts = False
    
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
    Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=False)
    '処理対象は 1番目のシートのみ。
    
    With w.Sheets(1)
        
        For b = 2 To .Range("B2").End(xlDown).Row
            If .Cells(b, "B") <> "" Then
                c = .Cells(b, "B")
                .Cells(2, "B") = c
                Set bk_name = Workbooks.Add

                w.Activate
                .Columns("A:P").Select
                .Columns("A:P").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("B1:B2"), CopyToRange:=bk_name.Sheets(1).Range("A1")
                
                bk_name.SaveAs Filename:=p & c & ".csv", FileFormat:=xlCSV, CreateBackup:=False
                bk_name.Close
                
                .Columns("B:B").Replace What:=c, Replacement:="", LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False
                
            End If
        Next b

    End With
         
    w.Close
    
    f = Dir
Loop

Application.DisplayAlerts = True

End Sub

id:inosisi4141

ありがとうございます。

上手くいったんですが最後に

Micrsoft Visual Basic

× 400

ok ヘルプ

という画面がでてくるのは

なにがおかしいのでしょうか。

そして最後に

最後に作ったファイルと同じものがBook 38 に作ってあり

変更保存しますかと聞いてきています。

よろしくお願いします。

2011/05/12 16:26:10

その他の回答(2件)

id:windofjuly No.1

うぃんど回答回数2625ベストアンサー獲得回数11492011/05/12 13:39:12

ポイント15pt

Excelに読み込んでからだと何かと問題になる可能性がありそうなので、テキストファイルとして処理する方法を選択しています

沢山のファイルを一度に処理したい場合には以前回答いただいたようにmainのほうでdir関数を用いてファイル一覧を取得するように改造してください

csv_splitを呼び出すパラメータは元になるcsvファイルと、書き出す先のフォルダです

Option Explicit

Sub main()
    Call csv_split("z:\a.csv", "z:\")
End Sub

Sub csv_split(csvFileName As String, folderName As String)
    Dim FSO As Object, readFileStream As Object, writeFileStream As Object
    Dim r As String, c() As String, c1() As String, f As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set readFileStream = FSO.OpenTextFile(csvFileName, 1)
    Do Until readFileStream.AtEndOfStream
        r = readFileStream.ReadLine
        c = Split(r, ",")
        c1 = Split(c(1), """")
        Set writeFileStream = FSO.OpenTextFile(folderName & c1(1) & ".csv", 8, True)
        writeFileStream.WriteLine r
        Set writeFileStream = Nothing
    Loop
End Sub
id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/05/12 14:30:23ここでベストアンサー

ポイント50pt

指定したフォルダ内にある csvのファイルを一括して処理します。

Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。

p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "csv")

End Sub


Sub jikkou(p As String, s As String)

Dim bk_name As Workbook
Application.DisplayAlerts = False
    
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
    Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=False)
    '処理対象は 1番目のシートのみ。
    
    With w.Sheets(1)
        
        For b = 2 To .Range("B2").End(xlDown).Row
            If .Cells(b, "B") <> "" Then
                c = .Cells(b, "B")
                .Cells(2, "B") = c
                Set bk_name = Workbooks.Add

                w.Activate
                .Columns("A:P").Select
                .Columns("A:P").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("B1:B2"), CopyToRange:=bk_name.Sheets(1).Range("A1")
                
                bk_name.SaveAs Filename:=p & c & ".csv", FileFormat:=xlCSV, CreateBackup:=False
                bk_name.Close
                
                .Columns("B:B").Replace What:=c, Replacement:="", LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False
                
            End If
        Next b

    End With
         
    w.Close
    
    f = Dir
Loop

Application.DisplayAlerts = True

End Sub

id:inosisi4141

ありがとうございます。

上手くいったんですが最後に

Micrsoft Visual Basic

× 400

ok ヘルプ

という画面がでてくるのは

なにがおかしいのでしょうか。

そして最後に

最後に作ったファイルと同じものがBook 38 に作ってあり

変更保存しますかと聞いてきています。

よろしくお願いします。

2011/05/12 16:26:10
id:windofjuly No.3

うぃんど回答回数2625ベストアンサー獲得回数11492011/05/12 15:52:05

ポイント15pt

「1行目は項目」を見逃していました。訂正版です

追記型なので書き出し先のフォルダはあらかじめ空っぽにしておいてください

(機械的に削除してしまうことも可能ですがデータ保全の面で、手動削除を推奨しておきます)

Option Explicit

Sub main()
    Call csv_split("z:\a.csv", "z:\")
End Sub

Sub csv_split(csvFileName As String, folderName As String)
    Dim FSO As Object, readFileStream As Object, writeFileStream As Object
    Dim r1 As String, r As String, c() As String, c1() As String, f As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set readFileStream = FSO.OpenTextFile(csvFileName, 1)
    r1 = readFileStream.ReadLine
    Do Until readFileStream.AtEndOfStream
        r = readFileStream.ReadLine
        c = Split(r, ",")
        c1 = Split(c(1), """")
        f = folderName & c1(1) & ".csv"
        Debug.Print f
        If FSO.FileExists(f) Then
            Set writeFileStream = FSO.OpenTextFile(f, 8)
        Else
            Set writeFileStream = FSO.OpenTextFile(f, 2, True)
            writeFileStream.WriteLine r1
        End If
        writeFileStream.WriteLine r
        Set writeFileStream = Nothing
    Loop
End Sub
id:inosisi4141

ありがとうございます。

データを置く場所とマクロを実行する場所とファイル名

が今一つ分かりません

マクロの実行の仕方はよくわかりません。


よろしくお願いします

2011/05/12 17:39:38
  • id:windofjuly
    うぃんど 2011/05/12 13:45:25
    追記:Excelと同じフォルダにcsvがあるならば呼び出し側は下記のような具合にすると楽です
    Call csv_split(ThisWorkbook.Path & "\a.csv", ThisWorkbook.Path & "\")
  • id:taknt
    >上手くいったんですが最後に Micrsoft Visual Basic × 400 ok ヘルプ という画面がでてくるのは

    >最後に作ったファイルと同じものがBook 38 に作ってあり 変更保存しますかと聞いてきています。


    作成しようとしたファイルと 同じ名前のファイルが 存在した場合とかかな?
  • id:windofjuly
    うぃんど 2011/05/12 18:09:14
    >マクロの実行の仕方はよくわかりません
    ここ最近たくさんやりとりしておられる taknt さんに合わせて main() を実行するだけにしてありますので、
    マクロを書く場所も、マクロを実行する方法も taknt さんのこれまでの回答と同じです
     
    >マクロを実行する場所
    特に制限はありません
     
    >データを置く場所、ファイル名
    私はzドライブにa.csvというファイルを準備して、
    同じくzドライブに分割後のファイルを書き出すようにしていますので下記のような具合になっています
    Call csv_split("z:\a.csv", "z:\")
     
    inosisi4141さんが例えばデータ.csvというファイルを分割したい場合の例をいくつかあげておきます
    (a)C:\test\データ.csv というファイルを分割してC:\test\分割\というフォルダに書き出したいとすれば下記のようにします
    Call csv_split("C:\test\データ.csv", "C:\test\分割\")
    (b)C:\test\データ.csv というファイルを分割してC:\test\というフォルダに書き出したいとすれば下記のようにします
    Call csv_split("C:\test\データ.csv", "C:\test\")
    (c)xlsと同じフォルダにデータ.csvがあり、同じフォルダ内に書き出したいとすれば下記のようにします
    Call csv_split(ThisWorkbook.Path & "\データ.csv", ThisWorkbook.Path & "\")
     
    回答3でも書いておきましたが、私のコードは、
    「一度実行した後にもう一度実行すると同一ファイルに何度も同じデータが書き込まれてしまいます」ので、
    実行前に保存先のフォルダを空っぽにしておく必要があります
    空っぽにしたりする場合に便利なので上記(a)のようにオリジナルファイルとは違うフォルダに保存するようにしておくのが楽です
  • id:inosisi4141
    ありがとうございました。
    データ.csvを元のファイル名にする場合はマクロ側の名前を(データ.csv)
    その都度変更しないといけないわけですね。
    いつも7個のファイル名に保存したデータを分割するので
    その分手間がかかりますね。

    takntさんの場合はマクロ側は手をつけずに出来ますので
    そのへんを変更できませんか。
    こちらで付けたファイル名のままで同じフォルダ内に分割できる。

    よろしくお願いします。
  • id:windofjuly
    うぃんど 2011/05/12 18:55:55
    一番手っ取り早くて確実な方法は必要な数だけmainの中に書いてしまうことになります
    Sub main()
    Call csv_split("C:\test\データ1.csv", "C:\test\分割\")
    Call csv_split("C:\test\データ2.csv", "C:\test\分割\")
    Call csv_split("C:\test\データ3.csv", "C:\test\分割\")
    Call csv_split("C:\test\データ4.csv", "C:\test\分割\")
    Call csv_split("C:\test\データ5.csv", "C:\test\分割\")
    Call csv_split("C:\test\データ6.csv", "C:\test\分割\")
    Call csv_split("C:\test\データ7.csv", "C:\test\分割\")
    End Sub

  • id:inosisi4141
    ありがとうございました。
    やはりマクロの中にかかないとだめですね
    毎回同じファイル名にしておくのも一つの考えですね。
    いろいろありがとうございました。
  • id:inosisi4141
    takntさん

    いま分割データをチェックしましたら

    データの中に日付の列が2列あってその日付が
    下記のようになってしまうのですがならない方法は
    ありますか。

    正常なデータ
    2011/5/4 15:05

    分割後のデータ
    5/4/2011 15:05

    日付が逆になってしまっている中には1ファイル正常なのもあります。

    分割前の日付データの列は
    E列とF列 が日付です

    よろしくお願いします。


  • id:windofjuly
    うぃんど 2011/05/12 19:46:16
    C:\test\にある全てのcsvファイルを分割したものを、
    C:\test\分割\ に保存する場合の例
    Sub main()
    Dim d1 As String, d2 As String, f As String
    d1 = "C:\test\"
    d2 = "C:\test\分割\"
    f = Dir(d1 & "*.csv")
    Do While f <> ""
    Call csv_split(d1 & f, d2)
    f = Dir
    Loop
    End Sub
  • id:inosisi4141
    ありがとうございます。

    うまくマクロが実行できません。
    いろいろやってみます。
    このマクロは何をどうするためのマクロでしょうか

    すみません理解できなくて。
  • id:windofjuly
    うぃんど 2011/05/13 13:03:23
    >このマクロは何をどうするためのマクロ
     
    takntさんのと同じく「マクロ側は手をつけずに出来ます」を実現するためのものです
    使い方は
    Sub main()
    Call csv_split("z:\a.csv", "z:\")
    End Sub

    Sub main()
    Dim d1 As String, d2 As String, f As String
    d1 = "C:\test\"
    d2 = "C:\test\分割\"
    f = Dir(d1 & "*.csv")  
    Do While f <> ""
    Call csv_split(d1 & f, d2)
    f = Dir
    Loop
    End Sub
    に置き換えるだけです
    d1とd2はあなたの環境にあわせて書き換える必要があるのはこれまで同様です
     
    エラーが出たのならば、エラーの内容を記述していただければフォローさせていただきますが、
    「Excelで開いて保存するという方式」のtakntさんのほうを選択なさって、
    次に進まれた(新質問 http://q.hatena.ne.jp/1305248608 )ようですから、
    ひとまずここまでとさせていただきます

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

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

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

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