質問です。

\test\の中にCSVファイルが複数あります。
このCSVファイルの属性は下記になっています。
この中のF列のデータが1から12までの数字になっております
このF列(数値)データを3つのグループに分割して
別の3つのTXTファイルに保存するマクロをお願いします。

1のtxtファイルにはF列データ   1
2のtxtファイルにはF列データ   11
3のtxtファイルにはF列データ   2,3,4,5,6,7,8,9,10,12

A列からS列までのデータを3つに分割して入るようにする
この分割したファイル名は

aaaaa.csvの場合
aaaaa-1.txt
aaaaa-2.txt
aaaaa-3.txt

bbbbb.csvの場合
bbbbb-1.txt
bbbbb-2.txt
bbbbb-3.txt

のようにCSVファイル名にそれぞれ1、2、3、の数字をつけたtxtファイルを作成する

CSVファイルの属性は下記になっていますが
G列は電話番号ですのでtxtに分割後0がとれないこと。
1行目は項目名
2行目からデータ
A列からS列まで

A(文字)
B(数値)
C(空白)
D(空白)
E(空白)
F(数値)
G(文字TEL090********)
H(数値)
I(数値)
J(数値)
K(空白)
L(空白)
M(空白)
N(数値)
O(文字)
P(文字)
Q(文字)
R(文字)
S(空白)

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/11/30 15:36:43
  • 終了:2011/12/04 19:26:49

ベストアンサー

id:taknt No.3

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/12/02 09:31:42

ポイント100pt

1行目が項目名ということで 2行目から処理するようにしました。

Public w As Workbook

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)
    '処理対象は 1番目のシートのみ。
    
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 2 Step -1
        
            If .Cells(gg, "F") <> 1 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    WRITE_CSVFile (p & f1 + "-1.txt")
    w.Close
    
      '処理対象は 1番目のシートのみ。
    
    csvImp (p & f)
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 2 Step -1
            Debug.Print .Cells(gg, "F")
            If .Cells(gg, "F") <> 11 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    WRITE_CSVFile (p & f1 + "-2.txt")
    w.Close
      
        '処理対象は 1番目のシートのみ。
    
    csvImp (p & f)
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 2 Step -1
            '2,3,4,5,6,7,8,9,10,12 のみとする
            If Not ((.Cells(gg, "F") >= 2 And .Cells(gg, "F") <= 10) Or .Cells(gg, "F") = 12) Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    WRITE_CSVFile (p & f1 + "-3.txt")
    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

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
        
        lRowCnt = lRowCnt + 1
        
    Loop
    
    
    Close #FNo

End If

End Sub


Sub WRITE_CSVFile(cnsFILENAME 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("F1") = "" Then
            Exit Sub
        End If
    
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
    
        ' 指定ファイルをOPEN(出力モード)
        Open cnsFILENAME For Output As #FNo
        
        ' 1行目から開始
        GYO = 1
        ' 最終行まで繰り返す
        Do Until GYO > ff
            ' レコードを出力(REC編集処理より受け取る)
            strREC = .Cells(GYO, 1).Value
            For COL = 2 To 19
                strREC = strREC & "," & .Cells(GYO, COL).Value
            Next COL
    
            Print #FNo, strREC
            ' 行を加算
            GYO = GYO + 1
        Loop
    End With
    
    Close #FNo
End Sub

他10件のコメントを見る
id:taknt

>文字行と空白行を削除するマクロはできますか
>だめでしたら別質問であげます。

ちょっとどういうふうにやりたいのか わからないので もう少し明確にしてもらったほうがいいです。

あと 今のプログラムに それを追加すると 確認も ややこしくなると思うので
別のプログラムにしたほうがいいと思います。

つまり、別で質問されたほうが いいと思いますよ。

2011/12/03 16:54:40
id:inosisi4141

ありがとうございました。
希望のマクロができました。

2011/12/04 19:25:52

その他の回答(2件)

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/11/30 16:00:40

ポイント100pt
Public w As Workbook

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

    
f = Dir(p & "*." & s, vbNormal)


Do While f <> ""
    f1 = Left(f, Len(f) - 4)
    FileCopy p & f, p & f1 + "-1.csv"
    FileCopy p & f, p & f1 + "-2.csv"
    FileCopy p & f, p & f1 + "-3.csv"

    csvImp (p & f1 + "-1.csv")
    '処理対象は 1番目のシートのみ。
    
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 1 Step -1
        
            If .Cells(gg, "F") <> 1 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    w.Save
    w.Close
    
      '処理対象は 1番目のシートのみ。
    
    csvImp (p & f1 + "-2.csv")
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 1 Step -1
        
            If .Cells(gg, "F") <> 11 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    w.Save
    w.Close
      
        '処理対象は 1番目のシートのみ。
    
    csvImp (p & f1 + "-3.csv")
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 1 Step -1
        
            If .Cells(gg, "F") = 1 Or .Cells(gg, "F") = 11 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    w.Save
    w.Close
      
    FileCopy p & f1 + "-1.csv", p & f1 + "-1.txt"
    FileCopy p & f1 + "-2.csv", p & f1 + "-2.txt"
    FileCopy p & f1 + "-3.csv", p & f1 + "-3.txt"

    Kill p & f1 + "-1.csv"
    Kill p & f1 + "-2.csv"
    Kill p & f1 + "-3.csv"
    f = Dir
Loop

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

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
        
        lRowCnt = lRowCnt + 1
        
    Loop
    
    
    Close #FNo

End If

End Sub


過去の質問で 0落ちしないで CSVを読み込む処理を作られた方のソースを利用させていただきました。

id:inosisi4141

ありがとうございます
txtが6データファイル中1ファイルしか分割しません
その分割した3つのtxtファイルもF列の数字を3ファイルに抽出してません
前回は0落ち以外はうまくいってましたが再度検証おねがいします。

2011/11/30 16:39:12
id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/11/30 18:14:06

ポイント100pt

出力するときに 何もないところは 出ていなかったようです。

空白一文字でもあれば いいみたいですが・・・
何もなくても出力するようにしました。

Public w As Workbook

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

    
f = Dir(p & "*." & s, vbNormal)


Do While f <> ""
    f1 = Left(f, Len(f) - 4)

    csvImp (p & f)
    '処理対象は 1番目のシートのみ。
    
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 1 Step -1
        
            If .Cells(gg, "F") <> 1 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    WRITE_CSVFile (p & f1 + "-1.csv")
    w.Close
    
      '処理対象は 1番目のシートのみ。
    
    csvImp (p & f)
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 1 Step -1
            Debug.Print .Cells(gg, "F")
            If .Cells(gg, "F") <> 11 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    WRITE_CSVFile (p & f1 + "-2.csv")
    w.Close
      
        '処理対象は 1番目のシートのみ。
    
    csvImp (p & f)
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 1 Step -1
        
            If .Cells(gg, "F") = 1 Or .Cells(gg, "F") = 11 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    WRITE_CSVFile (p & f1 + "-3.csv")
    w.Close
      
    FileCopy p & f1 + "-1.csv", p & f1 + "-1.txt"
    FileCopy p & f1 + "-2.csv", p & f1 + "-2.txt"
    FileCopy p & f1 + "-3.csv", p & f1 + "-3.txt"

    Kill p & f1 + "-1.csv"
    Kill p & f1 + "-2.csv"
    Kill p & f1 + "-3.csv"
    f = Dir
Loop

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

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
        
        lRowCnt = lRowCnt + 1
        
    Loop
    
    
    Close #FNo

End If

End Sub


Sub WRITE_CSVFile(cnsFILENAME 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("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
    
        ' 指定ファイルをOPEN(出力モード)
        Open cnsFILENAME For Output As #FNo
        
        ' 2行目から開始
        GYO = 1
        ' 最終行まで繰り返す
        Do Until GYO > ff
            ' レコードを出力(REC編集処理より受け取る)
            strREC = ""
            For COL = 1 To 19
                strREC = strREC & "," & .Cells(GYO, COL).Value
            Next COL
    
            Print #FNo, strREC
            ' 行を加算
            GYO = GYO + 1
        Loop
    End With
    
    Close #FNo
End Sub

他8件のコメントを見る
id:taknt

未確認ですが
strREC = strREC & "," & .Cells(GYO, COL).Value
の行を
strREC = strREC & vbTab & .Cells(GYO, COL).Value
に すれば タブ区切りになると思います。

2011/12/05 11:52:24
id:inosisi4141

遅くなってすみません
ありがとうございました
ご指示のように修正しましたらタブ区切りになりました

2011/12/06 15:01:44
id:taknt No.3

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/12/02 09:31:42ここでベストアンサー

ポイント100pt

1行目が項目名ということで 2行目から処理するようにしました。

Public w As Workbook

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)
    '処理対象は 1番目のシートのみ。
    
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 2 Step -1
        
            If .Cells(gg, "F") <> 1 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    WRITE_CSVFile (p & f1 + "-1.txt")
    w.Close
    
      '処理対象は 1番目のシートのみ。
    
    csvImp (p & f)
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 2 Step -1
            Debug.Print .Cells(gg, "F")
            If .Cells(gg, "F") <> 11 Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    WRITE_CSVFile (p & f1 + "-2.txt")
    w.Close
      
        '処理対象は 1番目のシートのみ。
    
    csvImp (p & f)
    With w.Sheets(1)
        
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
        
        For gg = ff To 2 Step -1
            '2,3,4,5,6,7,8,9,10,12 のみとする
            If Not ((.Cells(gg, "F") >= 2 And .Cells(gg, "F") <= 10) Or .Cells(gg, "F") = 12) Then
                .Rows(gg).Delete Shift:=xlUp
            End If
        
        Next gg
    End With
         
    WRITE_CSVFile (p & f1 + "-3.txt")
    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

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
        
        lRowCnt = lRowCnt + 1
        
    Loop
    
    
    Close #FNo

End If

End Sub


Sub WRITE_CSVFile(cnsFILENAME 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("F1") = "" Then
            Exit Sub
        End If
    
        If .Range("F2") = "" Then
            ff = 1
        Else
            ff = .Range("F1").End(xlDown).Row
        End If
    
        ' 指定ファイルをOPEN(出力モード)
        Open cnsFILENAME For Output As #FNo
        
        ' 1行目から開始
        GYO = 1
        ' 最終行まで繰り返す
        Do Until GYO > ff
            ' レコードを出力(REC編集処理より受け取る)
            strREC = .Cells(GYO, 1).Value
            For COL = 2 To 19
                strREC = strREC & "," & .Cells(GYO, COL).Value
            Next COL
    
            Print #FNo, strREC
            ' 行を加算
            GYO = GYO + 1
        Loop
    End With
    
    Close #FNo
End Sub

他10件のコメントを見る
id:taknt

>文字行と空白行を削除するマクロはできますか
>だめでしたら別質問であげます。

ちょっとどういうふうにやりたいのか わからないので もう少し明確にしてもらったほうがいいです。

あと 今のプログラムに それを追加すると 確認も ややこしくなると思うので
別のプログラムにしたほうがいいと思います。

つまり、別で質問されたほうが いいと思いますよ。

2011/12/03 16:54:40
id:inosisi4141

ありがとうございました。
希望のマクロができました。

2011/12/04 19:25:52

コメントはまだありません

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

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

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

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