質問です。

c:\test\の中に複数のCSVファイルがあります。
データは1行目からです
CSVファイル名と同じ文字をS行の1行目からA列のデータの数と同じ分
記入するマクロをお願いします
ああああ.csv
A列           C列
abcde         ああああ
edfgh         ああああ

回答の条件
  • 1人3回まで
  • 登録:
  • 終了:2011/12/08 15:39:47
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:taknt No.2

回答回数13539ベストアンサー獲得回数1198

ポイント90pt
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

その他の回答1件)

id:taknt No.1

回答回数13539ベストアンサー獲得回数1198

ポイント10pt
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

他2件のコメントを見る
id:taknt

あ、質問内容を勘違いしてました。
失礼しました。

2011/12/08 12:33:32
id:inosisi4141

ありがとうございます
これで完璧です
次の質問のS列の同じファイルごとにまとめて別CSVにまとめたファイル名で保存するのをおねがいします

2011/12/08 13:06:14
id:taknt No.2

回答回数13539ベストアンサー獲得回数1198ここでベストアンサー

ポイント90pt
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

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません