フォルダ内ファイル検索

質問

はじめまして
１１月から上司に言われて、勉強しながらマクロを組み始めているのですが、締め切りが迫っているにもかかわらずまだ完全な形になっておらず途方にくれております。
会社のＰＣからは書き込むことが出来ず、ソースの持ち出しも禁止な為、覚えている限りを、検索と作成で復元させて見ました。
ここから求めうる機能を持たせるためのソースがなかなか発見できなかったので、お知恵をお借りできればと思い、自宅から書き込みいたしました。
どのような機能にしたいかと言いますと、指定したフォルダ内のExcelファイルの特定のシート内（基本的にはシート２）のスペース、半角スペース（前後に文字のあるスペースは除く）と、全角文字（感じと平仮名、カタカナ以外）を検出し、検出結果として作成したExcelワークブックに、ファイル名と検出したセルの位置を書き出す使用にしたいのです。
会社のＰＣからは見ることは出来ても、書き込みは出来ませんので、お返事等は帰宅後になってしまいますが、ご容赦ください。
尚、Excelのバージョンは2003、VBAのバージョンは確認の仕方が分からず不明です。
よろしくお願いいたします。

ソースを書き込もうと思ったのですが、文字数制限に引っかかり書き込めませんでしたので、解説いたします。

こちらにあったAPI関数を使い、BrowseForFolderを使いフォルダを指定致しました。
後はEscキーでエラートラップをつくり、フォルダ内のファイルを一つ一つ開き検索するといったプログラムになっています

回答No.3

zap35

＃０１です。こういうことで良いでしょうか。
エクセルシート内で
1)半角文字
2)（漢字、ひらがな、カタカナ）以外の全角数字、全角英字、非漢字
3)先頭または末尾の全角空白
4)先頭または末尾の半角空白
の文字種が使われているセルのアドレスを一覧にしたい。

もしそうであればRegExpを用いて正規表現で検索するのが良いと思います。業務用のAPを丸々は書きませんが、開いているシート内で先述の文字種が使われているセルアドレスを表示するマクロをupします（フォルダ内のブックを開く処理と該当アドレスを記録する部分は記述していませんので、ご参考まで）

Sub Macro3()
Dim RE, strPattern, strPattern2, repPattarn, trgStr As String
Dim r As Range, i As Integer, mchItem
　Set RE = CreateObject("VBScript.RegExp")
　strPattern = "^\s|\s$|^　|　$|[!-~]|[。-゜]"
　strPattern2 = "[^ 　ーぁ-ヾ一-龠]"
　With RE
　　.IgnoreCase = True
　　.Global = True
　　For Each r In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 3)
　　　.Pattern = strPattern
　　　Set mchItem = .Execute(r.Formula)　'先頭&末尾の空白と半角文字を検索
　　　If mchItem.Count > 0 Then
　　　　MsgBox (r.Address)
　　　Else
　　　　.Pattern = strPattern2
　　　　Set mchItem = .Execute(r.Formula)　'かな、カナ、漢字、空白　上記以外を検索
　　　　If mchItem.Count > 0 Then
　　　　　MsgBox (r.Address)
　　　　End If
　　　End If
　　Next r
　End With
　Set RE = Nothing
End Sub

参考URL：

http://www.microsoft.com/japan/msdn/columns/scripting/scripting051099.aspx

お礼

なかなか返答が出来ず申し訳ありません。
むむむ・・・
なんか知らない構文が出てきています。
参考URLを見て理解を深めてないよう把握をしてみます。

本当にありがとうございます

補足

申し訳ありません。続きのソースを書かせていただきます。

検出ツール_Click_ESC:
If Err.Number = 18 Then
swESC = True
Resume
ElseIf Err.Number = 1004 Then
'隠しシートや対象なしの実行時にはエラーは無視
Resume Next
Else
'その他のエラーはメッセージ表示後終了
MsgBox Err.Description
End If
検出ツール_Click_EXIT:
With xlApp
.StatusBar = False 'ステータスバーを復帰
.EnableEvents = True 'イベント動作再開
.EnableCancelKey = xlInterrupt 'Esc動作を戻す
.Cursor = xlDefault 'カーソルをデフォルト
.ScreenUpdating = True '画面描画再開
End With
Set objWBK = Nothing
Set xlApp = Nothing
End Sub

今の所、この様な形でプログラムを組んで降ります。

始めにお答えをいただいたところに記述させていただいたのですが、改めて申しあげますと、
＞1)半角文字
こちらはアルファベット、数字、記号以外の半角文字です
＞2)（漢字、ひらがな、カタカナ）以外の全角数字、全角英字、非漢字
こちらは認識の相違はございません。
＞3)先頭または末尾の全角空白
＞4)先頭または末尾の半角空白
こちらも認識の相違はないと思われます。

教えていただいた部分を加筆して、編集してみます。

回答No.2

ASIMOV

どういうものを作ろうとしているのかは、解りましたが、困っている処が何なのかが、わかりません

なお、ExcelVBAについては、下記が充実していると思います

http://www.moug.net/

お礼

申し訳ありません。お礼の項目に続きを書かせていただきます。

xlApp.StatusBar = strFILENAME
'ワークブックを開く
Set objWBK = Workbooks.Open( _
Filename:=strPATHNAME & cnsYEN & strFILENAME)
lngROW = Range("65536").End(xlUp).Row
Cells.Find(What:=" ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).Activate
For lngROW = 1 To lngEndRow
If ActiveCell = " " Then
ActiveCell.Interior.ColorIndex = 3
End If
Cells.Find(What:=" ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).Activate
Next
If ActiveCell = " " Then
ActiveCell.Interior.ColorIndex = 3
End If
objWBK.Close savechanges:=False
strFILENAME = Dir
Loop
GoTo 検出ツール_Click_EXIT
やはり書ききれなかったのでまた続きは別のところに書かせていただきます。見づらくて申し訳ありません。
添付されたURLを見て勉強もしてみます。ありがとうございます

補足

ありがとうございます。
現在は下記のようなプログラムを組んでいます。

'Sub 検出ツール()
Const cnsYEN = "\"
Dim xlApp As Application 　 'Excel.Application
Dim objWBK As Workbook 'ワークブックのオブジェクト
Dim strPATHNAME As String '指定フォルダ名
Dim strFILENAME As String '検出したファイル名
Dim swESC As Boolean 'Ｅｓｃ判定
Dim c As Range '検索中のセルの値
Dim lngROW As Long
Dim lngEndRow As Long
'新規ブック作成
Workbooks.Add
'検出結果と名前をつけて保存
ChDir "C:\Documents and Settings\Administrator\デスクトップ"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Administrator\デスクトップ\検出結果.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
'「フォルダの参照」よりフォルダ名の取得（modAPIBrowsForFolder2に収容）
strPATHNAME = BrowseForFolder("フォルダを選んでね", True)
If strPATHNAME = "" Then Exit Sub
'指定フォルダ内のExcelワークブックのファイル名を取得する（１件目）
strFILENAME = Dir(strPATHNAME & "\*.xls", vbNormal)
If strFILENAME = "" Then
MsgBox "このフォルダにExcelのワークブックはないよ？"
Exit Sub
End If
Set xlApp = Application
With xlApp
.ScreenUpdating = False '画像描画停止
.EnableEvents = False 'イベント動作停止
.EnableCancelKey = xlErrorHandler 'Escキーでエラートラップにする
.Cursor = xlWait 'カーソルを砂時計に
End With
On Error GoTo 検出ツール_Click_ESC
'指定フォルダ内の全Excelワークブックについて繰り返す
Do While strFILENAME <> ""
'Escキー打鍵判定
DoEvents
If swESC = True Then
'中断するのかをメッセージで確認
If MsgBox("中断キーが押されたけど終わりにする？", _
vbInformation + vbYesNo) = vbYes Then
GoTo 検出ツール_Click_EXIT
Else
swESC = False
End If
End If

長く書ききれないので続きは改めて書かせていただきます

回答No.1

zap35

補足要求です。抽出条件として書かれている
＞スペース、半角スペース（前後に文字のあるスペースは除く）と、全角文字（感じと平仮名、カタカナ以外）を検出し…
の意味が理解できず、なんとも判断ができません。それに全角数字や記号はどうするのかも書かれていないように思います。

実例をあげて具体的に「どのような値が抽出対象か」を説明していただけませんか。

また「セルの位置を書き出す」とは「セルアドレスを値として書き込む」と解釈して良いですか？　出力するシートのイメージも書いていただく方が良いと思います。

最後に「基本的にはシート２」はどのように解釈すればよいのでしょう？　どのブックにも「シート２」という名前のシートが存在するのですか。シート名が無いときは、そのブックは処理対象外で良いですか。

補足

お返事遅くなり申し訳ありません。
＞スペース、半角スペース（前後に文字のあるスペースは除く）と、全角文字（感じと平仮名、カタカナ以外）を検出し…
の意味が理解できず、なんとも判断ができません。それに全角数字や記号はどうするのかも書かれていないように思います。

実例をあげて具体的に「どのような値が抽出対象か」を説明していただけませんか。

内容を説明しますと、あるExcelシートに書き出したデータをtxtファイルにツールで変換し、それをサーバに入力しているそうなのですが、半角であるものが全角で入力されてたり、本来ブランクのセルに何かの間違いでスペースが入っているとエラーが発生してしまうんです。

なのでそのエラーを発生させる文字を検索したいんです。
本来使用されているのが全角の漢字、平仮名、半角のアルファベット、数字、記号、前後を文字に挟まれたスペース（例：120 siru）を使用しているので、それ以外のもの（単品の半角スペース、全角スペース含む）を検索し、別のExcelブックにファイル名と、検索に引っかかったセルアドレスを値として書き込む使用にしたいのです。

シート2の方ですが正確に言いますと、常に二枚目のシートというわけではないので、こちらはシート名がアルファベットだけで構成されているシートを検索目標にするように出来ればと思っています。

出力するシートのイメージは、簡潔に、検索対象のファイル名、検索結果のセルアドレスを表のような感じで書き出せたらと思います。

この様な答えで補足にはなっているでしょうか？