\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ファイルの属性は下記になっています
1行目は項目名
2行目からデータ
A列からS列まで
A(文字)
B(数値)
C(空白)
D(空白)
E(空白)
F(数値)
G(文字)
H(数値)
I(数値)
J(数値)
K(空白)
L(空白)
M(空白)
N(数値)
O(文字)
P(文字)
Q(文字)
R(文字)
S(空白)
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 Int(Trim(.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 Int(Trim(.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 ((Int(Trim(.Cells(gg, "F"))) >= 2 And Int(Trim(.Cells(gg, "F"))) <= 10) Or Int(Trim(.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
Option Explicit Sub Macro1() Const path = "\test" Const grab = "*.csv" Const keyCol = "F" ' F列 Const group1 = 1 Const group2 = 11 Dim file As String Dim last As Long Dim i As Long file = Dir(path & "\" & grab, vbNormal) Do While file <> "" With Workbooks.Open(path & "\" & file) last = Sheets(1).Cells(Rows.Count, keyCol).End(xlUp).Row Sheets(1).Copy after:=Sheets(1) With ActiveSheet For i = last To 1 Step -1 If Range(keyCol & i).Value <> group1 Then Range(i & ":" & i).Delete Shift:=xlUp Next i ActiveWorkbook.SaveAs Filename:=path & "\" & Sheets(1).Name & "-1" & grab, FileFormat:=xlCSV, CreateBackup:=False End With Sheets(1).Copy after:=Sheets(1) With ActiveSheet For i = last To 1 Step -1 If Range(keyCol & i).Value <> group2 Then Range(i & ":" & i).Delete Shift:=xlUp Next i ActiveWorkbook.SaveAs Filename:=path & "\" & Sheets(1).Name & "-2" & grab, FileFormat:=xlCSV, CreateBackup:=False End With Sheets(1).Copy after:=Sheets(1) With ActiveSheet For i = last To 1 Step -1 If Range(keyCol & i).Value = group1 Or Range(keyCol & i).Value = group2 Then Range(i & ":" & i).Delete Shift:=xlUp End If Next i ActiveWorkbook.SaveAs Filename:=path & "\" & Sheets(1).Name & "-3" & grab, FileFormat:=xlCSV, CreateBackup:=False End With .Close SaveChanges:=False End With file = Dir Loop End Sub
ありがとうございます
\test\の中にaaaaa.csvとbbbbb.csvのデータファイルを入れてマクロ実行するとsheetがふえてエラー400の表示がでます原因はなんでしょうか
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" Set w = Workbooks.Open(Filename:=p & f1 + "-1.csv", UpdateLinks:=False, ReadOnly:=False) '処理対象は 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番目のシートのみ。 Set w = Workbooks.Open(Filename:=p & f1 + "-2.csv", UpdateLinks:=False, ReadOnly:=False) 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番目のシートのみ。 Set w = Workbooks.Open(Filename:=p & f1 + "-3.csv", UpdateLinks:=False, ReadOnly:=False) 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
なお 0落ちしないようにするには 全面的な作り変えが必要となります。
そうしますとこちらの勝手な判断ですが0落ちしない版の質問を再アップすれば作り変えをやっていただけますか是非お願いしたいのです。
よろしくお願いします。
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 Int(Trim(.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 Int(Trim(.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 ((Int(Trim(.Cells(gg, "F"))) >= 2 And Int(Trim(.Cells(gg, "F"))) <= 10) Or Int(Trim(.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
ありがとうございました。
いろいろご無理もうしあげました。大変良いのができております。
テストの結果空白行も文字行も除いた1、2、3、の振り分けができております。ありがとうございました。
ありがとうございました。
2011/12/04 19:22:08いろいろご無理もうしあげました。大変良いのができております。
テストの結果空白行も文字行も除いた1、2、3、の振り分けができております。ありがとうございました。