質問です

\test\のホルダーに1個のCSVファイルがあります
1行目は項目です、データは2行目からです
A列からS列まであります
S列は文字列でその中にあるファイル名をグループ毎にそのファイル名を付けて
同じホルダ内にCSVファイルに出力して保存するマクロをおねがいします
各ファイルの1行目は元データの1行目の項目をコピーします
もし処理が早くなるのでしたらS列のファイル名はソートしても可ですその時は条件として指示ください
1ファイルのデータは相当ありますので早いマクロでおねがいします
A列とG列には頭に0が付いた数字の文字列(090********)がありますのでとれないように注意ください

S列
aaaaaa
aaaaaa
bbbbbb
bbbbbb

ファイル名
aaaaaa.csv
bbbbbb.csv

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2012/03/08 19:49:06
  • 終了:2012/03/09 12:06:49

ベストアンサー

id:oil999 No.1

oil999回答回数1728ベストアンサー獲得回数3202012/03/08 23:51:19

ポイント100pt

以下のマクロをお試しください。
生成するファイルは、元のCSVがある場所と同じディレクトリに作ります。
以前のマクロを流用しているので、"C:/test/" 以下に複数のCSVファイルがあったら、複数処理します。サブディレクトリは検索しないようにしてあります。
処理速度については、それほど遅くならないようにしたつもりです。

Option Explicit

'1ファイル処理
Sub convFile(path As String, fname As String)
    Dim buf As String, idx As String, fname2 As Variant
    Dim ix As Long
    Dim dc As Object
    
    Set dc = CreateObject("Scripting.Dictionary")
    'CSVファイル読み込み
    fname = path & fname
    Open fname For Input As #1
    Line Input #1, idx      '見出し行
    Do Until EOF(1)
        Line Input #1, buf
        ix = InStrRev(buf, ",")
        fname2 = Right(buf, Len(buf) - ix)
        buf = Left(buf, ix - 1)
        If (dc.Exists(fname2) = False) Then
            dc.Item(fname2) = buf
        Else
            dc.Item(fname2) = dc.Item(fname2) & vbCrLf & buf
        End If
    Loop
    Close #1
    'ファイル作成
    For Each fname2 In dc.Keys
        Open path & fname2 & ".csv" For Output As #2
        Print #2, idx
        Print #2, dc.Item(fname2)
        Close #2
    Next
End Sub

'ファイル探索+処理実行
Sub hogeConv(path As String, ext As String)
    Dim fcol As Object, re As Object
    Dim flist As Variant, remat As Variant
    Dim pat As String
    'サブディレクトリ探索(有効にしたい場合はコメントを消してください)
'    Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).SubFolders
'    For Each flist In fcol
'        Call hogeConv(path & flist.Name & "/", ext)
'    Next flist
'    Set fcol = Nothing
    '処理対象ファイル探索+処理実行
    Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).Files
    Set re = CreateObject("VBScript.RegExp")
    pat = "\." & ext & "$"
    With re
        .Pattern = pat
        .IgnoreCase = True
        .Global = True
        For Each flist In fcol
            Set remat = .Execute(flist.Name)
            If remat.Count > 0 Then Call convFile(path, flist.Name)
        Next flist
    End With
    Set re = Nothing
    Set fcol = Nothing
End Sub

Sub main()
    Call hogeConv("C:/test/", "csv")
End Sub
他4件のコメントを見る
id:inosisi4141

質問を立てましたのでよろしくお願いします

2012/03/13 16:38:52
id:inosisi4141

オリジナル・ファイルを、そのまま "c:\test\" に置いて、
分割ファイルを "c:\era\" に保存するということであれば
可能です。

"c:\test\"と"c:\era\"の名前は変更可能でおねがいします

2012/03/13 17:24:55
  • id:inosisi4141
    ファイルを分割してCSVファイルにS列のファイル名で保存する際
    S列のデータは削除して空白になるようにお願いします。
    元データには残っています

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

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

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

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