c:\test\の中に複数のCSVファイルがあります。
データは1行目からです
CSVファイル名と同じ文字をS行の1行目からA列のデータの数と同じ分
記入するマクロをお願いします
ああああ.csv
A列 C列
abcde ああああ
edfgh ああああ
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) With w.Sheets(1) If .Range("A2") = "" Then ff = 1 Else ff = .Range("A1").End(xlDown).Row End If For gg = 1 To ff .Cells(gg, "S") = f1 Next gg End With w.Save 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
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) csvImp (p & f) w.Sheets(1).Columns("A:A").Copy w.Sheets(1).Columns("S:S") w.Save 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(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 読み込み数 strREC = strREC & "," & .Cells(GYO, COL).Value Next COL Print #FNo, strREC ' 行を加算 GYO = GYO + 1 Loop End With Close #FNo End Sub
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) With w.Sheets(1) If .Range("A2") = "" Then ff = 1 Else ff = .Range("A1").End(xlDown).Row End If For gg = 1 To ff .Cells(gg, "S") = f1 Next gg End With w.Save 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
あ、質問内容を勘違いしてました。
2011/12/08 12:33:32失礼しました。
ありがとうございます
2011/12/08 13:06:14これで完璧です
次の質問のS列の同じファイルごとにまとめて別CSVにまとめたファイル名で保存するのをおねがいします