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

質問です。
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 いいいい



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

▽最新の回答へ

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


大丈夫かな?


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

●質問をもっと探す●



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