人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

質問です。
\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(空白)

●質問者: inosisi
●カテゴリ:コンピュータ インターネット
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● うぃんど
●15ポイント
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

inosisiさんのコメント
ありがとうございます \test\の中にaaaaa.csvとbbbbb.csvのデータファイルを入れてマクロ実行するとsheetがふえてエラー400の表示がでます原因はなんでしょうか

2 ● きゃづみぃ
●130ポイント
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

inosisiさんのコメント
ありがとうございます \test\の中にaaaaa.csvとbbbbb.csvのデータファイルを入れてマクロを実行するとファイルが見つかりませんのメッセージがでます。マクロが実行できません原因はなんでしょうか? お手数おかけします。

きゃづみぃさんのコメント
環境によっては うまくいかなかったみたいなので とりあえず エラーが発生しないように修正しました。 あとは 速度的に どうか・・・ですけど。

inosisiさんのコメント
ありがとうございました。 上手くゆきました速度もこれでOKです。 ただ一つだけ問題がありまして実はG列は電話番号の列で TXTに移動したら最初の0が取れてしまいますが何か取れない方法はありますか 最初に説明すればよかったのですが申し訳ありません それ以外は良くできでいて完璧です。 よろしくお願いします。

きゃづみぃさんのコメント
>TXTに移動したら最初の0が取れてしまいますが何か取れない方法はありますか ああ CSVファイルを開いたときの宿命ですね。 CSVを開いた時点で 0は 消えてます。 0の前に 'とかつけるしかないですが・・・。 でも それだと 'つきの電話番号になってしまいますが・・・。

きゃづみぃさんのコメント
なお 0落ちしないようにするには 全面的な作り変えが必要となります。

inosisiさんのコメント
そうしますとこちらの勝手な判断ですが0落ちしない版の質問を再アップすれば作り変えをやっていただけますか是非お願いしたいのです。 よろしくお願いします。

3 ● きゃづみぃ
●155ポイント ベストアンサー
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


inosisiさんのコメント
ありがとうございました。 いろいろご無理もうしあげました。大変良いのができております。 テストの結果空白行も文字行も除いた1、2、3、の振り分けができております。ありがとうございました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ