質問です。

c:\test\のなかにCSVファイルがあります。(できれば複数CSVファイル可能希望)
1行目は項目です
データは2行目からです
データはA列からS列までです
S列に文字列(ファイル名)があります
S列はソートされています
S列のファイル名に該当する行データを別CSVファイルにコピーして
S列のファイル名でCSVファイルで保存するマクロをおねがいします。
1行目の項目行は各ファイル同じ
A列       S列
名前      ファイル名
aaaa      ああああ
bbbb      ああああ
cccc      いいいい
dddd      いいいい

答え
ファイル名
ああああ.csv
A列       S列
名前      ファイル名
aaaa      ああああ
bbbb      ああああ

ファイル名
いいいい.csv
A列       s列
名前      ファイル名
cccc      いいいい
dddd      いいいい

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/12/08 10:25:34
  • 終了:2011/12/08 15:38:08

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13538ベストアンサー獲得回数11982011/12/08 13:35:09

ポイント200pt
Public w As Workbook
Public 読み込み数 As Integer


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 As Workbook
Dim gg As Long
Application.DisplayAlerts = False

Dim fdb() As String
    
a = 1
f = Dir(p & "*." & s, vbNormal)
Do While f <> ""
    ReDim Preserve fdb(a)
    fdb(a - 1) = f
    a = a + 1
    f = Dir
Loop


For aaa = 0 To a - 2
    f = fdb(aaa)
    f1 = Left(f, Len(f) - 4)

    csvImp (p & f)
    Call WRITE_CSVFile(p)
    w.Close
Next aaa

Application.DisplayAlerts = True

End Sub


Sub csvImp(csFName As String)

    Const csDelimiter As String = ","
    
    Dim FNo As Integer
    
    Dim wsObj As Worksheet
    
    Dim strGet As String
    
    Dim lRowCnt As Long
    
    Dim i As Long
    
    FNo = FreeFile
    読み込み数 = 0
    
    If Dir(csFName) <> "" Then
    
        Open csFName For Input As #FNo
        Set w = Workbooks.Open(Filename:=csFName, UpdateLinks:=False, ReadOnly:=False)
        
        Set wsObj = Workbooks(w.Name).Sheets(1)
        lRowCnt = 1
        
        Do Until EOF(FNo)
        
            Line Input #FNo, strGet
            
            For i = LBound(Split(strGet, csDelimiter)) To UBound(Split(strGet, csDelimiter))
            
                If IsNumeric(Split(strGet, csDelimiter)(i)) = True And Left(Split(strGet, csDelimiter)(i), 1) = "0" Then
                
                   wsObj.Cells(lRowCnt, i + 1).NumberFormatLocal = "@"
                
                End If
                
                wsObj.Cells(lRowCnt, i + 1) = Split(strGet, csDelimiter)(i)
        
            Next i
            If 読み込み数 < i Then
                読み込み数 = i
            End If
            lRowCnt = lRowCnt + 1
            
        Loop
        
        Close #FNo
    
    End If
End Sub


Sub WRITE_CSVFile(pa As String)
    Dim GYO As Long                 ' 収容するセルの行
    Dim GYOMAX As Long              ' データが収容された最終行
    Dim strREC As String
    Dim FNo As Integer
    
    Dim lRowCnt As Long
    
    FNo = FreeFile

    ' 最終行の取得
    With w.Sheets(1)
        If .Range("S1") = "" Then
            Exit Sub
        End If
    
        If .Range("S2") = "" Then
            ff = 1
        Else
            ff = .Range("S1").End(xlDown).Row
        End If
        cnsFILENAME = ""
    
        str見出し = .Cells(1, 1).Value
        For COL = 2 To 読み込み数
            str見出し = str見出し & "," & .Cells(1, COL).Value
        Next COL
        
        
        ' 2行目から開始
        GYO = 2
        ' 最終行まで繰り返す
        Do Until GYO > ff
            If cnsFILENAME <> .Cells(GYO, "S") Then
                If cnsFILENAME <> "" Then
                    Close #FNo
                End If
                cnsFILENAME = .Cells(GYO, "S")
            
                ' 指定ファイルをOPEN(出力モード)
                Open pa & cnsFILENAME + ".csv" For Output As #FNo
                Print #FNo, str見出し
                
            End If
            ' レコードを出力(REC編集処理より受け取る)
            strREC = .Cells(GYO, 1).Value
            For COL = 2 To 読み込み数
                strREC = strREC & "," & .Cells(GYO, COL).Value
            Next COL
    
            Print #FNo, strREC
            ' 行を加算
            GYO = GYO + 1
        Loop
    End With
    
    Close #FNo
    

End Sub


大丈夫かな?

id:inosisi4141

ありがとうございます。
上手く分割されてファイル保存できました。
マクロはすごいですね感心しました。
いろいろ試してまた何かありましたら
質問させていただきます。
本当にありがとうございました。

2011/12/08 15:37:51
  • id:inosisi4141
    A列とG列は090*******のように頭に0がついた文字列が含まれています
    コピーの際新しくS列のファイル名で保存する際取れないようにおねがいします。

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

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

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

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