人力検索はてな
モバイル版を表示しています。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ファイルの属性は下記になっていますが
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(空白)

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

▽最新の回答へ

1 ● きゃづみぃ
●100ポイント
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を読み込む処理を作られた方のソースを利用させていただきました。


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

2 ● きゃづみぃ
●100ポイント

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

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

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


inosisiさんのコメント
ありがとうがざいます。 修正をお願いしたい部分があります 1、txtファイルへコピーした時にA列に該当する列がB列になっていて列がずれています。 2、F列の中に数字以外が混じっている場合がありますので2,3,4,5,6,7,8,9,10,12の数字のみを3へコピーできますか この場合1行目の項目はコピーしない(3にかぎってコピーしてます) 3、c:\test\の中に複数のCSVファイルがあるのですが連続してできませんか 以上よろしくおねがいします 特に1、のデータの前に,がついているのは削除できますか

きゃづみぃさんのコメント
最近、ちょっと忙しくなったので そんなに テストしきれてなくて 失礼しました。 ファイル関係の関数を用いたことで、次のCSVファイルを見つけることが できなくなってしまったようです。 別の手段を考えないと ダメなようです。 もう少し検討してみます。

inosisiさんのコメント
ありがとうございます。 お忙しいところ申し訳ございません。

inosisiさんのコメント
お忙しいでしょうから今回は連続処理マクロはやめて現在の1ファイルごとで結構です。 1、のTXTにコピーしたときにカンマ,が行頭についてしまうことだけでも修正できたら助かります。 よろしくお願いします。 2、3、は今回省略します。 最初に作ってもらった連続でファイル処理できるマクロももったいたいので 使いたいと思いますが多少修正できますか 現在データごとTXTにコピーしなくて結構ですから1、2、3のtxtファイルを 連続で作成するだけのマクロに修正できるとありがたいのですが いろいろ要望言ってすみません。

きゃづみぃさんのコメント
最後に回答したものは いかがでしょうか?

inosisiさんのコメント
最後に回答していただいたのがNO2ですが txtにコピーしたあと行頭に,カンマがついてしまう それとF列の数が正確でない抽出結果です 合ってたりなかったりです

きゃづみぃさんのコメント
最後の回答は No3です。

inosisiさんのコメント
takntさんへ 最後の回答NO3は確認しました ありがとうございました 今回のtxt1、2、3に保存する質問内容に説明不足 がありました。 txtはタブ区切りで保存したいのですが変更可能ですか 変更可能であれば質問を上げたいのですが 現在はカンマ区切りで保存されています。 よろしくお願いいたします

きゃづみぃさんのコメント
未確認ですが strREC = strREC & "," & .Cells(GYO, COL).Value の行を strREC = strREC & vbTab & .Cells(GYO, COL).Value に すれば タブ区切りになると思います。

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

3 ● きゃづみぃ
●100ポイント ベストアンサー

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


きゃづみぃさんのコメント
こちらのほうを 実行させてみてください。

inosisiさんのコメント
ありがとうございます 振り分けはちゃんとやってますが肝心のF列の1、11、234567891012、の振り分け数が違っているようです お手数おかけしますがよろしくおねがいします。

inosisiさんのコメント
カンマ,も直ってました ありがとうございました。

きゃづみぃさんのコメント
振り分け数が違うというのは ちょっと 意味が わからないです。 たとえば 1が 3行、11が 5行だったら それぞれ 項目名+3行、項目名+5行 出力されることになります。

きゃづみぃさんのコメント
プログラムは 修正しました(項目名は そのまま出すようにしました)

inosisiさんのコメント
振り分け数が違うというのは 1例として項目を含め 1が321のところ123件 11が489のところ1993件 12を含むが609おところ223件 1例として 1が42のところ30 11が56のところ44 12が3のところ2 大幅なちがいです

きゃづみぃさんのコメント
うーーん、何でだろう? 空白とか入ってたりします? たとえば ,1空白, みたいな感じで ,1, と入っていたら 数値扱いされるはずです。

inosisiさんのコメント
F列の中に文字行と空白行が混じっていました。申し訳ありませんでした。 数字だけにしましたら上手くいゆきました。 いろいろありがとうございました。 属性が標準と数値とありますが標準でもOKでしょうか必ず数値にしないとだめでしょうか。 文字行と空白行を削除するマクロはできますか だめでしたら別質問であげます。

きゃづみぃさんのコメント
>属性が標準と数値とありますが標準でもOKでしょうか必ず数値にしないとだめでしょうか。 空白まじりというのが わかれば 対処は できます。

きゃづみぃさんのコメント
こちらは 新しく回答できないので、 最初の質問のほうに 回答しておきます。

きゃづみぃさんのコメント
>文字行と空白行を削除するマクロはできますか >だめでしたら別質問であげます。 ちょっとどういうふうにやりたいのか わからないので もう少し明確にしてもらったほうがいいです。 あと 今のプログラムに それを追加すると 確認も ややこしくなると思うので 別のプログラムにしたほうがいいと思います。 つまり、別で質問されたほうが いいと思いますよ。

inosisiさんのコメント
ありがとうございました。 希望のマクロができました。
関連質問

●質問をもっと探す●



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