質問です

c:\test\の中に複数のCSVファイルがあります(複数のCSVファイルは連続でマクロ実行)
列はA列からS列まであります
1行目は項目行です
データは2行目からです
F列に1から12までの複数の数字のデータがあります
このデータの中にこれ以外のデータが存在した場合はその行を削除するマクロ
をお願いします

A列とG列には頭に0から始まる文字(090*******)が含まれます
のでとれないように注意ねがいます

マクロの結果
F列データは1から12までの整数のみのこります
例へば
0001
1000
0010
1aaa
aaaa
は削除の対象です

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2012/02/21 19:17:05
  • 終了:2012/02/21 19:57:07

ベストアンサー

id:oil999 No.1

oil999回答回数1728ベストアンサー獲得回数3202012/02/21 19:30:51

ポイント100pt

以下のマクロをお試しください。
各ファイルの1行目は見出し行として、そのままコピーするようにしてあります。
シート [Sheet1] にログを記録する処理を残してあります。

Option Explicit

Private logSheet As String
Private logRow As Long

'ログシート作成
Private Sub makeLogSheet()
    Dim ws As Worksheet
    Dim flag As Boolean
    
    logSheet = "Sheet1"
    flag = False
    For Each ws In Worksheets
        If ws.Name = logSheet Then flag = True
    Next ws
    If (flag = True) Then
        Worksheets(logSheet).Cells.Clear
    Else
        Set ws = Worksheets.Add
        ws.Name = logSheet
    End If
    logRow = 1
End Sub

'処理結果をログシートに残す
Private Sub putLog(path As String, fname As String, ln As Long)
    Worksheets(logSheet).Cells(logRow, 1) = path
    Worksheets(logSheet).Cells(logRow, 2) = fname
    Worksheets(logSheet).Cells(logRow, 3) = ln
    logRow = logRow + 1
End Sub

'1行処理
Function convRow(sour As String, ln As Long, path As String, fname As String) As String
    Dim items() As String
    items = Split(sour, ",")
   
    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    With re
        .Pattern = "^[1-9][0-9]?$"
        .IgnoreCase = True
        .Global = True
    End With
    
    'F列があるかどうか
    If (UBound(items) < 5) Then
        Call putLog(path, fname, ln)
        convRow = ""
    '数字かどうか
    ElseIf (re.test(items(5)) = False) Then
        Call putLog(path, fname, ln)
        convRow = ""
    '1以上12以下かどうか
    ElseIf (items(5) < 1 Or items(5) > 12) Then
        Call putLog(path, fname, ln)
        convRow = ""
    Else
        convRow = sour
    End If
    Set re = Nothing
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
    '見出し行
    Line Input #1, buf
    Print #2, buf
    'データ行の処理
    ln = 2
    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 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
    'サブディレクトリ探索
    Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).SubFolders
    For Each flist In fcol
        Call hogeConv(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 makeLogSheet
    Call hogeConv("C:/test/", "csv")
End Sub

他3件のコメントを見る
id:inosisi4141

ありがとうございました
調べてみます

2012/02/23 18:40:10
id:inosisi4141

他のCSVファイルで試してもエラーは出ませんでした
また出たら調べてみます

2012/02/23 18:53:39

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

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

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

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

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