質問です。

\test\のホルダーの中に複数の下記の様な階層ホルダーに複数のTXTファイルがあります
ああああ
    いいいい
        うううう
の3つの階層のホルダーがあり
最下位層の「うううう」のホルダーの中に複数のtxtファイル(タブ切り)があります
そのtxtファイル(タブ切り)をチェック修正するマクロをお願いします
データは1列目からあります
答え
A(文字)  頭に0がついている文字列(090********)も含まれる
B(文字)
C(数値)  もし数値でない場合は数値に修正する
D(空白)
E(空白)
F(数値)
G(文字)  頭に0がついている文字列(090********)
H(数値)
I(数値)
J(数値)
K(空白)
L(空白)
M(空白)
N(数値)
O(文字)
P(文字)
Q(文字)
R(数値)
S(空白)  もし空白行がない場合は空白行を追加する

もしこれ以外の不正データの場合はエラー表示する
上記の修正が不可の場合はエラー表示でかまいません
注意する列はC列とS列ですこの列の修正だけでもかまいません

よろしくお願いします

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2012/01/06 10:34:53
  • 終了:2012/01/06 16:36:57

ベストアンサー

id:kodairabase No.1

kodairabase回答回数661ベストアンサー獲得回数802012/01/06 14:25:51

ポイント200pt

コメントにしたがってプログラムを修正しました。
"C:/test/" 以下にある拡張子 txt のファイルをすべて処理します。

数値のエラーチェックを行い、sheet1に結果を記入するようになっています。
エラーシートの各行の内容は下記の通り。

パス名ファイル名エラー発生行番号エラー内容

なお、エラーが発生しても修正ルールが分からないので、そのまま置換します。

「空白」というのは、半角空白文字が1文字あると解釈しました。
空白文字のエラーチェックはしていません。強制的に空白文字が入るようになっています。

Option Explicit

Public Grow As Integer

'エラーメッセージ記入
Sub putError(path As String, fname As String, ln As Integer, msg As String)
    Dim sheet As Worksheet
    Set sheet = Worksheets("Sheet1")
    sheet.Cells(Grow, 1).Value = path
    sheet.Cells(Grow, 2).Value = fname
    sheet.Cells(Grow, 3).Value = ln
    sheet.Cells(Grow, 4).Value = msg
    Grow = Grow + 1
End Sub

'整数バリデーションチェック
Function hogeint(x As Variant, a As Integer, b As Integer) As Boolean
    Dim d As Double
    Dim n As Integer
    hogeint = False
    If (IsNumeric(x)) Then
        d = CDbl(x)
        n = Round(d, 0)
        If (d <> n) Then
            hogeint = False
        ElseIf (n < a Or n > b) Then
            hogeint = False
        Else
            hogeint = True
        End If
    End If
End Function

'1行処理
Function lineconv(str As String, ln As Integer, path As String, fname As String) As String
    Dim items As Variant
    Dim i As Integer
    Dim flag As Boolean
    
    flag = True
    items = Split(str, vbTab)
    'C(数値) 0又は1
    If (hogeint(items(2), 0, 1) = False) Then
        Call putError(path, fname, ln, "C列が0又は1でない")
        flag = False
    End If
    'F(数値) 1から12までの整数
    If (hogeint(items(5), 1, 12) = False) Then
        Call putError(path, fname, ln, "F列が1から12までの整数でない")
        flag = False
    End If
    'H(数値) 0のみ
    If (hogeint(items(7), 0, 0) = False) Then
        Call putError(path, fname, ln, "H列が0ではない")
        flag = False
    End If
    'I(数値) 2桁の整数
    If (hogeint(items(8), 0, 99) = False) Then
        Call putError(path, fname, ln, "I列が2桁の整数ではない")
        flag = False
    End If
    'J(数値) 2桁の整数
    If (hogeint(items(9), 10, 99) = False) Then
        Call putError(path, fname, ln, "J列が2桁の整数ではない")
        flag = False
    End If
    'N(数値) 1のみ
    If (hogeint(items(13), 1, 1) = False) Then
        Call putError(path, fname, ln, "N列が1ではない")
        flag = False
    End If
    'R(数値) 3桁の整数
    If (hogeint(items(17), 100, 999) = False) Then
        Call putError(path, fname, ln, "J列が2桁の整数ではない")
        flag = False
    End If
    '
    If (flag) Then
        items(3) = " "               'D(空白)
        items(4) = " "               'E(空白)
        items(10) = " "              'K(空白)
        items(11) = " "              'L(空白)
        items(12) = " "              'M(空白)
        lineconv = items(0)
    End If
    lineconv = items(0)
    For i = 1 To 17
        lineconv = lineconv & vbTab & items(i)
    Next i
    lineconv = lineconv & vbTab & " "
End Function

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

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


Sub main()
    Grow = 1
    Call searchFileAndGo("D:/あいう/", "txt")
End Sub
他5件のコメントを見る
id:inosisi4141

ありがとうございました
上手くいきました
こちらの説明不足でお手間おかけしました

2012/01/07 09:47:58
id:inosisi4141

S列は半角の空白文字ではなくタブでできますか
結果てきにS列の半角空白文字を削除することになりました

2012/01/16 18:57:42
  • id:inosisi4141
    ホルダーの階層が2つの場合もあります
    ああああ
        いいいい
  • id:inosisi4141
    エラーがある場合は実行用エクセルのsheet1にtxtファイル名を表記するだけでもOKです
  • id:taknt
    >C(数値)  もし数値でない場合は数値に修正する

    これは どういうことでしょうか?

    データは以下のようにして存在するとしたら どうしますか?

    C列の箇所だけとりあげます。
    例1
    ・・・<タブ>1<タブ>・・・

    例2
    ・・・<タブ>01<タブ>・・・

    例3
    (全角)
    ・・・<タブ>1<タブ>・・・

    例3
    (数値以外)
    ・・・<タブ>A<タブ>・・・


    あと
    >S(空白)  もし空白行がない場合は空白行を追加する
    ですが


    ・・・R列<タブ>
    の場合
    ・・・R列<タブ>空白1文字
    というようにすればいいのでしょうか?

  • id:inosisi4141

    C列は例1のように0か1のみの数字です
    R列は最初の行に空白1文字でお願いします
    全体は以下を参照ねがいます
    もしエラーデータがあるtxtファイルがあればファイル名とホルダー名も合わせて表示できるとありがたいです。

    A(文字)
    B(文字)
    C(数値) 0又は1
    D(空白)
    E(空白)
    F(数値) 1から12までの整数
    G(文字) 
    H(数値) 0のみ
    I(数値) 2桁の整数
    J(数値) 2桁の整数
    K(空白)
    L(空白)
    M(空白)
    N(数値) 1のみ
    O(文字)
    P(文字)
    Q(文字)
    R(数値) 3桁の整数
    S(空白) 無い場合は最初の行に空白1文字入れる
  • id:kodairabase
    上記コメントに合うようにプログラムを修正しました。

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

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

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

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