質問です

c:\TEST\のホルダーに複数のcsvファイルがあります
G列にランダムな6桁の整数データがA列にあるデータ行の分だけ記入できるマクロをお願いします
最初の数字が0にならないないようにしたいのですがもし0がくる場合は列全体を文字列に
なるようにお願いします
データは1行目からあります
よろしくお願いします

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2012/11/10 14:32:37
  • 終了:2012/11/17 14:35:03

回答(1件)

id:oil999 No.1

oil999回答回数1728ベストアンサー獲得回数3202012/11/10 17:01:05

ポイント100pt

G列に100000~999999からランダムに選んだ整数を入れます。
A列がない行には入れません。

Option Explicit

'拡張子を除く
Function GetFNameFromFStr(sFileName As String) As String
    Dim sFileStr As String
    Dim lFindPoint As Long
    Dim lStrLen As Long
    
    '文字列の右端から"."を検索し、左端からの位置を取得する
    lFindPoint = InStrRev(sFileName, ".")
    
    '拡張子を除いたファイル名の取得
    sFileStr = Left(sFileName, lFindPoint - 1)

    GetFNameFromFStr = sFileStr
End Function

Function addCol(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 num As Integer
    
    num = 7      'G列の番号
    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
    
    'num列にstrを追加
    ix1 = 1
    For Each item In items
        If (ix1 = 1) Then
            addCol = item
        ElseIf (items(0) <> "" And ix1 = num) Then
            addCol = addCol & "," & str
        Else
            addCol = addCol & "," & item
        End If
        ix1 = ix1 + 1
    Next
    For i = ix1 To num
        If (items(0) <> "" And i = num) Then
            addCol = addCol & "," & str
        Else
            addCol = addCol & ","
        End If
    Next i
End Function

'1ファイル処理
Sub addFileName(path As String, fname As String)
    Dim buf As String, idx As String
    Dim fname2 As String, fname3 As String
    Dim x As Long
    
    '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)
        x = Int((999999 - 100000 + 1) * Rnd + 100000)
        Line Input #1, buf
        buf = addCol(buf, str(x), ",")     '半角カンマ区切り以外の場合は第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
            fname = GetFNameFromFStr(flist.name)
            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

id:inosisi4141

ありがとうございました
うまくいきました
'半角カンマ区切り以外の場合は第3引数を変更してください
の意味がわからないのですが

2012/11/10 17:48:35
id:oil999

CSVのカラム区切りは通常半角カンマ , ですが、
もしそれ以外の形式(例:タブ区切り)だったら変更してください
という意味です。
巧く動作したのであれば、とくに変更する必要はありません。

2012/11/10 21:28:13

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

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

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

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

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