質問です

C:\TEST\のフォルダーに複数のcsvファイルがあります

そのファイル名と同じ文字をS列にデータのある行(最終行)の分だけ記入コピーするマクロをお願いします

行データは1行目からあります
列データはA列からR列まであります

できれば途中に空白行があっても最終行まで記入できと助かります
処理速度はできるだけ早くおねがいします
よろしくお願いします

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2012/11/10 14:22:21
  • 終了:2012/11/13 18:25:47
id:inosisi4141

データ行はA列のデータ(文字列)行数の分だけでよいです
A列に空白行がある場合もあります
もし空白行があってマクロが実行できない場合は空白行を削除またはソート
して空白行をなくす方法があれば助かりますその後マクロが継続してエラーにならないようにできれば良いのですが

C:\TEST\の複数のCSVファイルは連続してマクロ実行できること

ベストアンサー

id:oil999 No.1

oil999回答回数1728ベストアンサー獲得回数3202012/11/10 16:46:06

ポイント100pt

処理後、オリジナルのファイルは "*.bak" にリネームして同じフォルダに残しています。
空白行のS列にもファイル名を入れます。

Option Explicit

Function addColS(buf As String, str As String, sep As String) As String
    Dim pos1, pos2 As Integer
    Dim i, ix1, ix2 As Integer
    Dim items() As Variant, item As Variant
    Dim S As Integer
    
    S = 19      'S列の番号
    pos1 = 1
    ix1 = 0
    ReDim items(ix1)
    'sepでカラムを分割
    Do While pos1 <= Len(buf)
        pos2 = InStr(pos1, buf, sep, vbTextCompare)
        If pos2 < pos1 Then
            pos2 = Len(buf) + 1
        End If
        ReDim Preserve items(ix1)   '配列要素数を再設定
        items(ix1) = Trim$(Mid$(buf, pos1, pos2 - pos1))
        ' シングルクォーテーション、ダブルクォーテーションで囲まれている場合は両端文字を取り除く
        If (((Left$(items(ix1), 1) = """") And (Right$(items(ix1), 1) = """")) Or ((Left$(items(ix1), 1) = "'") And (Right$(items(ix1), 1) = "'"))) Then
            items(ix1) = Trim$(Mid$(items(ix1), 2, Len(items(ix1)) - 2))
        End If
        pos1 = pos2 + 1
        ix1 = ix1 + 1
    Loop

    'S列にstrを追加
    ix1 = 1
    For Each item In items
        If (ix1 = 1) Then
            addColS = item
        ElseIf (ix1 = S) Then
            addColS = addColS & "," & str
        Else
            addColS = addColS & "," & item
        End If
        ix1 = ix1 + 1
    Next
    For i = ix1 To S
        If (i = S) Then
            addColS = addColS & "," & str
        Else
            addColS = addColS & ","
        End If
    Next i
End Function
c
'1ファイル処理
Sub addFileName(path As String, fname As String)
    Dim buf As String, idx As String
    Dim fname2 As String, fname3 As String
        
    'CSVファイル読み込み&書き込み
    fname2 = path & fname
    fname3 = path & fname & ".bak"
    Name fname2 As fname3
    Open fname3 For Input As #1
    Open fname2 For Output As #2
    Do Until EOF(1)
        Line Input #1, buf
        buf = addColS(buf, fname, ",")      'S列にパス名+ファイル名を入れたい場合は、第2引数をfname2にしてください
                                            '半角カンマ区切り以外の場合は第3引数を変更してください
        Print #2, buf
    Loop
    Close #2
    Close #1
End Sub

'ファイル探索+処理実行
Sub hogeConv(path As String, ext As String)
    Dim fcol As Object, re As Object
    Dim flist As Variant, remat As Variant
    Dim pat As String, fname As String
    Dim n As Long
    
    '処理対象ファイル探索+処理実行
    Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).Files
    Set re = CreateObject("VBScript.RegExp")
    pat = "\." & ext & "$"
    With re
        .Pattern = pat
        .IgnoreCase = True
        .Global = True
        For Each flist In fcol
            Set remat = .Execute(flist.name)
            If remat.Count > 0 Then
                Call addFileName(path, flist.name)
            End If
        Next flist
    End With
    Set re = Nothing
    Set fcol = Nothing
End Sub

Sub main()
    Call hogeConv("C:/test/", "csv")
End Sub
他3件のコメントを見る
id:oil999

> S列にファイル名だけ入れたい場合
パス名が不要であれば、このままで動くはずです。

2012/11/10 21:29:23
id:inosisi4141

お世話様です
fname = GetFNameFromFStr(flist.Name)

fname = (flist.Name)
に修正したら直りました

質問ですが
BAKファイルを作らない場合はどのように修正
すれば良いのでしょうか
よろしくお願いします

2012/11/15 11:27:03

その他の回答(0件)

id:oil999 No.1

oil999回答回数1728ベストアンサー獲得回数3202012/11/10 16:46:06ここでベストアンサー

ポイント100pt

処理後、オリジナルのファイルは "*.bak" にリネームして同じフォルダに残しています。
空白行のS列にもファイル名を入れます。

Option Explicit

Function addColS(buf As String, str As String, sep As String) As String
    Dim pos1, pos2 As Integer
    Dim i, ix1, ix2 As Integer
    Dim items() As Variant, item As Variant
    Dim S As Integer
    
    S = 19      'S列の番号
    pos1 = 1
    ix1 = 0
    ReDim items(ix1)
    'sepでカラムを分割
    Do While pos1 <= Len(buf)
        pos2 = InStr(pos1, buf, sep, vbTextCompare)
        If pos2 < pos1 Then
            pos2 = Len(buf) + 1
        End If
        ReDim Preserve items(ix1)   '配列要素数を再設定
        items(ix1) = Trim$(Mid$(buf, pos1, pos2 - pos1))
        ' シングルクォーテーション、ダブルクォーテーションで囲まれている場合は両端文字を取り除く
        If (((Left$(items(ix1), 1) = """") And (Right$(items(ix1), 1) = """")) Or ((Left$(items(ix1), 1) = "'") And (Right$(items(ix1), 1) = "'"))) Then
            items(ix1) = Trim$(Mid$(items(ix1), 2, Len(items(ix1)) - 2))
        End If
        pos1 = pos2 + 1
        ix1 = ix1 + 1
    Loop

    'S列にstrを追加
    ix1 = 1
    For Each item In items
        If (ix1 = 1) Then
            addColS = item
        ElseIf (ix1 = S) Then
            addColS = addColS & "," & str
        Else
            addColS = addColS & "," & item
        End If
        ix1 = ix1 + 1
    Next
    For i = ix1 To S
        If (i = S) Then
            addColS = addColS & "," & str
        Else
            addColS = addColS & ","
        End If
    Next i
End Function
c
'1ファイル処理
Sub addFileName(path As String, fname As String)
    Dim buf As String, idx As String
    Dim fname2 As String, fname3 As String
        
    'CSVファイル読み込み&書き込み
    fname2 = path & fname
    fname3 = path & fname & ".bak"
    Name fname2 As fname3
    Open fname3 For Input As #1
    Open fname2 For Output As #2
    Do Until EOF(1)
        Line Input #1, buf
        buf = addColS(buf, fname, ",")      'S列にパス名+ファイル名を入れたい場合は、第2引数をfname2にしてください
                                            '半角カンマ区切り以外の場合は第3引数を変更してください
        Print #2, buf
    Loop
    Close #2
    Close #1
End Sub

'ファイル探索+処理実行
Sub hogeConv(path As String, ext As String)
    Dim fcol As Object, re As Object
    Dim flist As Variant, remat As Variant
    Dim pat As String, fname As String
    Dim n As Long
    
    '処理対象ファイル探索+処理実行
    Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).Files
    Set re = CreateObject("VBScript.RegExp")
    pat = "\." & ext & "$"
    With re
        .Pattern = pat
        .IgnoreCase = True
        .Global = True
        For Each flist In fcol
            Set remat = .Execute(flist.name)
            If remat.Count > 0 Then
                Call addFileName(path, flist.name)
            End If
        Next flist
    End With
    Set re = Nothing
    Set fcol = Nothing
End Sub

Sub main()
    Call hogeConv("C:/test/", "csv")
End Sub
他3件のコメントを見る
id:oil999

> S列にファイル名だけ入れたい場合
パス名が不要であれば、このままで動くはずです。

2012/11/10 21:29:23
id:inosisi4141

お世話様です
fname = GetFNameFromFStr(flist.Name)

fname = (flist.Name)
に修正したら直りました

質問ですが
BAKファイルを作らない場合はどのように修正
すれば良いのでしょうか
よろしくお願いします

2012/11/15 11:27:03

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

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません