質問です。

\test\の中にCSVのファイルが複数あります
データは文字列でA列に1行目からあります
このデータの最後に半角スペース及び全角スペースが含まれている文字があります
このデータの中から半角スペースおよび全角スペースがあれば取るマクロをおねがいします
aaaa@bbb␣
結果答え
aaaa@bbb

@の後ろに全角または半角の数字で0から9までのいずれかの文字があればその行を削除を実行できるマクロも合わせておねがいします。

aaa@2bbb の場合は削除
aaa@2bbb  の場合は削除

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2012/01/12 14:04:55
  • 終了:2012/01/13 16:37:31

ベストアンサー

id:kodairabase No.1

kodairabase回答回数661ベストアンサー獲得回数802012/01/12 21:08:38

ポイント100pt

回答コメントにしたがって修正しました。
お試しください。

A列しかないという条件で作りました。
空白以外に置換したい文字があれば、mainの
Call delHoge("C:/test/", "csv", "#")
の3番目の引数で指定してください。2種類以上の文字を書くこともできます。

Option Explicit

'1列処理
Function convCol(sour As String, str As String) As String
    Dim dest As String
    Dim re As Object
    Dim remat As Variant
    Dim pat As String
    dest = sour
    
    '指定文字削除
    If (str <> "") Then
        Set re = CreateObject("VBScript.RegExp")
        pat = "[" & str & "]+"
        With re
            .Pattern = pat
            .IgnoreCase = True
            .Global = True
        End With
        dest = re.Replace(dest, "")
        Set re = Nothing
    End If

    '@のあとに数字がある場合は行削除
    Set re = CreateObject("VBScript.RegExp")
    pat = "@[0-90123456789]+"
    With re
        .Pattern = pat
        .IgnoreCase = True
        .Global = True
        Set remat = .Execute(dest)
        If remat.Count > 0 Then dest = ""
    End With
    Set re = Nothing
    
    convCol = dest
End Function


'1行処理
Function convRow(buf As String, ln As Long, path As String, fname As String, str As String) As String
    Dim items As String, dest As String
    Dim ch As String
    
'   items = Split(buf, ",")      '列に分解
    buf = Trim(buf)              '先頭・末尾の空白削除
    'クォーテーション削除
    ch = Left(buf, 1)
    If (ch = "'" Or ch = """") Then buf = Mid(buf, 2, Len(buf) - 2)
    '1列変換
    dest = convCol(buf, str)
    convRow = dest
End Function

'1ファイル処理
Sub convFile(path As String, fname As String, str As String)
    Dim ln As Long
    Dim buf As String
    Dim fname1 As String, fname2 As String
    fname1 = path & fname
    fname2 = path & fname & ".$$$"
    Open fname1 For Input As #1
    Open fname2 For Output As #2
    ln = 1
    Do Until EOF(1)
        Line Input #1, buf
        buf = convRow(buf, ln, path, fname, str)
        If (buf <> "") Then Print #2, buf
        ln = ln + 1
    Loop
    Close #1
    Close #2
    Kill fname1                 'オリジナル・ファイル削除
    Name fname2 As fname1
End Sub

'ファイル探索+処理実行
Sub delHoge(path As String, ext As String, str As String)
    Dim fcol As Object, re As Object
    Dim flist As Variant, remat As Variant
    Dim pat As String
    'サブディレクトリ探索
    Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).SubFolders
    For Each flist In fcol
        Call delHoge(path & flist.Name & "/", ext, str)
    Next flist
    Set fcol = Nothing
    '処理対象ファイル探索+処理実行
    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 convFile(path, flist.Name, str)
        Next flist
    End With
    Set re = Nothing
    Set fcol = Nothing
End Sub

Sub main()
    Call delHoge("C:/test/", "csv", "#")
End Sub
他5件のコメントを見る
id:inosisi4141

Sub main()
Call delHoge("C:/test/", "csv", "#")

置換したい文字を複数追加したいのですができますか?
たとえば""とか)とか今後置換したい文字がでてきても追加できるようにしたいのですがよろしくおねがいします

2012/02/08 17:36:57
id:inosisi4141

最初に書いてありました
複数できましたありがとうございました

2012/02/08 18:29:14
  • id:inosisi4141
    半角および全角のスペース(空白)は文字の前にもあれば削除おねがいします
  • id:inosisi4141
    文字のなかに#があれば削除おねがいします
    削除したい文字が追加できる機能があれま助かります
    マクロの中に記述する方法でもOKです

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

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

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

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