人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

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

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

●質問者: inosisi
●カテゴリ:コンピュータ インターネット
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● oil999
●100ポイント ベストアンサー

以下のマクロをお試しください。
各ファイルの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


inosisiさんのコメント
早速ありがとうございます 上手くいきましたログはあって正解ですの削除した実績が 残るので また何かありましたらご質問いたします

inosisiさんのコメント
「パス名が無効です」のメッセージがでてマクロが止まりました 何か原因は?、2回目は出ませんでした。

oil999さんのコメント
>「パス名が無効です」のメッセージがでてマクロが止まりました "C:/test/" が存在しなかったか、あるいは "C:/test/" 以下がアクセス禁止、不可視属性、システム属性のディレクトリが存在していた場合にエラーが出る可能性があります。

inosisiさんのコメント
ありがとうございました 調べてみます

inosisiさんのコメント
他のCSVファイルで試してもエラーは出ませんでした また出たら調べてみます
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ