質問です

\test\のホルダーの中にtxtの拡張子のファイルが複数あります
データs列の空白行がタブと半角とになっているデータを半角を削除してタブの空白だけに
するマクロをおねがいします
s列
タブ+半角
答え
タブ

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2012/01/16 12:09:41
  • 終了:2012/01/17 19:42:35

ベストアンサー

id:kodairabase No.2

kodairabase回答回数661ベストアンサー獲得回数802012/01/16 14:03:53

ポイント90pt

コメントいただいたように「データはタブ区切り」で作り直してみました。
お試しください。

Option Explicit

'行を列に分離
Function splitRow2Col(sour As String)
    Dim i As Integer, ln As Integer, num As Integer
    Dim c As String, q As String, buf As String
    Dim items(1000, 1) As Variant

    ln = Len(sour)
    q = ""
    buf = ""
    num = 0
    For i = 1 To ln
        c = Mid(sour, i, 1)
        '列区切り文字
        If (c = vbTab Or c = ",") Then
            If (q = "*") Then
                q = ""
            ElseIf (q = "") Then
                items(num, 0) = buf
                items(num, 1) = q
                num = num + 1
                buf = ""
            Else
                buf = buf & c
            End If
        'シングルクォーテーション
        ElseIf (c = "'") Then
            If (q = "") Then
                q = "'"
                buf = ""    'クォーテーションの前の文字は無視
            ElseIf (q = "'") Then
                If (i < ln) Then
                    items(num, 0) = buf
                    items(num, 1) = q
                    num = num + 1
                    q = "*"
                    buf = ""
                End If
            Else
                buf = buf & c
            End If
        'ダブルクオーテーション
        ElseIf (c = """") Then
            If (q = "") Then
                q = """"
                buf = ""    'クォーテーションの前の文字は無視
            ElseIf (q = """") Then
                If (i < ln) Then
                    items(num, 0) = buf
                    items(num, 1) = q
                    num = num + 1
                    q = "*"
                    buf = ""
                End If
            Else
                buf = buf & c
            End If
        Else
            buf = buf & c
        End If
    Next i
    items(num, 0) = buf
    items(num, 1) = q
    num = num + 1
    '出力配列の作成
    Dim items2() As Variant
    ReDim items2(num, 1)
    For i = 0 To num
        items2(i, 0) = items(i, 0)
        items2(i, 1) = items(i, 1)
    Next i
    splitRow2Col = items2
End Function

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


'1行処理
Function convRow(buf As String, ln As Long, path As String, fname As String) As String
    Dim items() As Variant
    Dim sour As String
    Dim i As Integer

    items = splitRow2Col(buf)     '列に分解
    sour = items(18, 0)
    items(18, 0) = convCol(sour)  'S列変換
    '1行組み立て
    convRow = items(0, 1) & items(0, 0) & items(0, 1)
    For i = 1 To 18
        convRow = convRow & vbTab & items(i, 1) & items(i, 0) & items(i, 1)
    Next i
End Function

'1ファイル処理
Sub convFile(path As String, fname 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)
        If (buf <> "") Then Print #2, buf
        ln = ln + 1
    Loop
    Close #1
    Close #2
    Kill fname1                 'オリジナル・ファイル削除
    Name fname2 As fname1
End Sub

'ファイル探索+処理実行
Sub delSpace(path As String, ext 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 delSpace(path & flist.Name & "/", ext)
    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)
        Next flist
    End With
    Set re = Nothing
    Set fcol = Nothing
End Sub

Sub main()
    Call delSpace("C:/test/", "txt")
End Sub
id:inosisi4141

すみません
データはタブ区切りです修正できますか
申し訳ありませんよろしくおねがいします

2012/01/16 19:06:50
id:inosisi4141

ありがとうございました
完璧です
何度もお手間とらせて申し訳ございませんでした

2012/01/17 19:41:49

その他の回答(1件)

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982012/01/16 12:25:21

ポイント10pt

秀丸で開いて 置換で

 \t を なしに
(\tの後に半角空白(空白の数は とりあえず ひとつで なくなるまで 繰り返し実行する)
(なし というのは 何も 入れない状態)

正規表現にチェックを入れて
置換では ダメですか?

複数ファイルの場合は、grepして置換というのを使えばいいでしょう。

id:taknt

ある程度、簡単な対応は 秀丸などのエディタを使ったほうが 便利です。
というか、マクロを作るのは ちょっと 手間ですからねぇ・・・。

2012/01/16 12:26:34
id:inosisi4141

ありがとうございました
参考にさせていただきます

2012/01/17 19:43:41
id:kodairabase No.2

kodairabase回答回数661ベストアンサー獲得回数802012/01/16 14:03:53ここでベストアンサー

ポイント90pt

コメントいただいたように「データはタブ区切り」で作り直してみました。
お試しください。

Option Explicit

'行を列に分離
Function splitRow2Col(sour As String)
    Dim i As Integer, ln As Integer, num As Integer
    Dim c As String, q As String, buf As String
    Dim items(1000, 1) As Variant

    ln = Len(sour)
    q = ""
    buf = ""
    num = 0
    For i = 1 To ln
        c = Mid(sour, i, 1)
        '列区切り文字
        If (c = vbTab Or c = ",") Then
            If (q = "*") Then
                q = ""
            ElseIf (q = "") Then
                items(num, 0) = buf
                items(num, 1) = q
                num = num + 1
                buf = ""
            Else
                buf = buf & c
            End If
        'シングルクォーテーション
        ElseIf (c = "'") Then
            If (q = "") Then
                q = "'"
                buf = ""    'クォーテーションの前の文字は無視
            ElseIf (q = "'") Then
                If (i < ln) Then
                    items(num, 0) = buf
                    items(num, 1) = q
                    num = num + 1
                    q = "*"
                    buf = ""
                End If
            Else
                buf = buf & c
            End If
        'ダブルクオーテーション
        ElseIf (c = """") Then
            If (q = "") Then
                q = """"
                buf = ""    'クォーテーションの前の文字は無視
            ElseIf (q = """") Then
                If (i < ln) Then
                    items(num, 0) = buf
                    items(num, 1) = q
                    num = num + 1
                    q = "*"
                    buf = ""
                End If
            Else
                buf = buf & c
            End If
        Else
            buf = buf & c
        End If
    Next i
    items(num, 0) = buf
    items(num, 1) = q
    num = num + 1
    '出力配列の作成
    Dim items2() As Variant
    ReDim items2(num, 1)
    For i = 0 To num
        items2(i, 0) = items(i, 0)
        items2(i, 1) = items(i, 1)
    Next i
    splitRow2Col = items2
End Function

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


'1行処理
Function convRow(buf As String, ln As Long, path As String, fname As String) As String
    Dim items() As Variant
    Dim sour As String
    Dim i As Integer

    items = splitRow2Col(buf)     '列に分解
    sour = items(18, 0)
    items(18, 0) = convCol(sour)  'S列変換
    '1行組み立て
    convRow = items(0, 1) & items(0, 0) & items(0, 1)
    For i = 1 To 18
        convRow = convRow & vbTab & items(i, 1) & items(i, 0) & items(i, 1)
    Next i
End Function

'1ファイル処理
Sub convFile(path As String, fname 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)
        If (buf <> "") Then Print #2, buf
        ln = ln + 1
    Loop
    Close #1
    Close #2
    Kill fname1                 'オリジナル・ファイル削除
    Name fname2 As fname1
End Sub

'ファイル探索+処理実行
Sub delSpace(path As String, ext 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 delSpace(path & flist.Name & "/", ext)
    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)
        Next flist
    End With
    Set re = Nothing
    Set fcol = Nothing
End Sub

Sub main()
    Call delSpace("C:/test/", "txt")
End Sub
id:inosisi4141

すみません
データはタブ区切りです修正できますか
申し訳ありませんよろしくおねがいします

2012/01/16 19:06:50
id:inosisi4141

ありがとうございました
完璧です
何度もお手間とらせて申し訳ございませんでした

2012/01/17 19:41:49
  • id:inosisi4141
    データは1行目からです
    データはA列からS列まであり
    A列とG列に頭に0がつく文字列が含まれていますので0が取れないように注意ねがいます
  • id:inosisi4141
    すみませんA列からS列まではタブ区切りです
    申し訳ありますン修正できますか
  • id:taknt
    タブの後に空白があるような ところは 一括して ないようにできますよ。
  • id:kodairabase
    >すみませんA列からS列まではタブ区切りです
    S列はダブルクォーテーションで囲まれているということですよね?
    つまり
    "hogeタブ空白"

    "hoge空白"
    のようにすればいいということですか?
  • id:inosisi4141
    "hogeタブ空白"

    "hogeタブ"
    のようにできますか

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

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

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

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