[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダ内の複数のファイルから問題あるものだけ抽出したい』（かもすけ）
はじめまして。
恐れ入りますが、教えて頂きたくお願いいたします。
500個程度のファイルが入っているフォルダがあります。
そのファイルから、問題あるものだけを抽出したいのですが、どのような方法がありますでしょうか。
＜状況＞
A列：品番、B列：指定納期、C列：回答納期････
行に関しては取り扱い品番数ごととなるので、3行ですむファイルや、20行あるファイルなどそれぞれです。
＜やりたいこと＞
C列の回答納期で、8ｹﾀの数字以外をインプットしている場合のみ、新しいファイルに「ファイル名」を記載したい
です。
いろんなマクロを組んだのですが、うまく照合できず困っております。
なにとぞお知恵をお貸し頂きたくお願いいたします。
＜ 使用 Excel：Excel2003、使用 OS：WindowsXP ＞
500ファイルですか…実用に耐えるかな？
細かいところは置いてますが、新規ブックの標準モジュールへ
以下を貼り付け実行してみてください。
検索対象のファイルが存在しているフォルダは変数ptを変更してください。
Sub sample()
Const pt As String = "C:\test\" '要変更
Dim i As Long, ii As Long, fn As String, tbl
fn = Dir(pt & "*.xls")
If fn <> "" Then
If vbNo = MsgBox("検索を開始します。", vbYesNo) Then Exit Sub
Application.ScreenUpdating = False
Do
With Workbooks.Open(pt & fn)
With .Sheets(1)
tbl = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Offset(1).Row).Value
End With
If IsArray(tbl) Then
For i = 1 To UBound(tbl)
If (Not tbl(i, 1) Like String(8, "#")) * (Len(tbl(i, 1))) Then
ii = ii + 1
ThisWorkbook.Sheets(1).Range("A" & ii).Value = fn
Exit For
End If
Next i
End If
.Close False
End With
fn = Dir()
Loop Until fn = ""
Application.ScreenUpdating = True
End If
MsgBox "処理が完了しました。"
End Sub
（Jera） 2014/01/17(金) 17:32
Jera様
ご教示有難うございました！
教えていただいた内容を標準ﾓｼﾞｭｰﾙに貼り付け、ﾃﾞｰﾀの在り処を変更させ実行しましたところ、C列がブランクの場合もNGと出てしまうのか、実行できたすべてのファイルの名前が挙がってしまいました。
また途中で「型が一致しない」とエラーが出て、デバックを見ると「 For i = 1 To UBound(tbl)」の部分がマーキングされていました。
とまってしまったファイルを見ると、見出しの行の他、品番が１つしかない(=1行しかない）状態でした。
何度も申し訳ないのですが、再度やり方を教えていただけませんでしょうか。
恐れ入りますがよろしくお願いいたします。
（かもすけ） 2014/01/20(月) 10:12
対策が不十分でしたね…。上のコードを変更したので、再度試してみてください。 一行目の見出しは検索に含んでいません。 （Jera） 2014/01/20(月) 11:45
セキュリティ警告はクリアにしております。
マクロを起動すると、本来であれば3分少々かかっていた処理が即「処理が完了しました」と
出てしまい、かつ、該当のファイル名が抽出されていない状況です。
解決策がありましたら、教えていただきたくお願いいたします。
なお、ファイルの場所や名前は変更されておりません。
（かもすけ） 2014/05/15(木) 09:39
>なお、ファイルの場所や名前は変更されておりません。 とのことですが、対象ファイルの拡張子は変わっていないでしょうか。 2007以降の標準拡張子はxlsx もしくはxlsmです。 それが問題であれば fn = Dir(pt & "*.xls") を fn = Dir(pt & "*.xls*") に変更してどうでしょうか。 （Mook） 2014/05/15(木) 09:52
fn = Dir(pt & "*.xls*") に変えてみたのですが、状況は同じでした（涙）
ありがとうございます。
（かもすけ） 2014/05/15(木) 10:39
本題とは関係ないかもしれませんが、
>ファイル拡張子はxlsのままで、xlsxのものはxlsに拡張子変更を行っております。
拡張子変更はどのように行ったのでしょうか？
いったんブックを開いてxls形式で保存し直したのでしょうか？ それともブックを開かずに拡張子の変更をしただけなのでしょうか？ （カリーニン） 2014/05/15(木) 10:47
こんな感じで？ シート名が共通なら、開かないで処理できますが？
Option Explicit
Sub test()
Dim myDir As String, fn As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
Application.ScreenUpdating = False
fn = Dir(myDir & "*.xls")
Do While fn <> ""
With Workbooks.Open(myDir & fn).Sheets(1)
On Error Resume Next
If .[sumproduct((len(c1:c10000)<>8)*(len(c1:c10000)>0))] Then
ThisWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp)(2).Value = fn
End If
On Error GoTo 0
.Parent.Close False
End With
fn = Dir
Loop
Application.ScreenUpdating = True
End Sub
（seiya） 2014/05/15(木) 12:09
なお、sheet名はすべて共通です。
（かもすけ） 2014/05/15(木) 16:04
こんな感じでどうでしょう？
Sub test()
Dim myDir As String, fn As String, temp As String, x, CurrentDir As String
Const sn As String = "Sheet1" '<----実際のシート名に変更
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
CurrentDir = CurDir
ChDrive myDir: ChDir myDir
fn = Dir(myDir & "*.xls")
Do While fn <> ""
temp = "'[" & fn & "]" & sn & "'!r1c3:r10000c3"
x = ExecuteExcel4Macro("count(if((" & temp & "<>"""")*(len(" & temp & ")<>8)," & temp & "))")
If x > 0 Then
ThisWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp)(2).Value = fn
End If
fn = Dir
Loop
ChDrive CurrentDir: ChDir CurrentDir
End Sub
（seiya） 2014/05/15(木) 17:29
x = ExecuteExcel4Macro("count(if((" & temp & "<>"""")*(len(" & temp & ")<>8)," & temp & "))")
と出てしまいます。
何度も申し訳ございません。
（かもすけ） 2014/05/22(木) 09:18
シート名/ファイルパス名に Apostrophe ' が入っていたりしますか？ （seiya） 2014/05/22(木) 10:42
ご返信ありがとうございました。
sheet名は"納指進捗表"、かつ実際確認したい列はS列なので、以下のとおりに書き換えました。
Sub test()
Dim myDir As String, fn As String, temp As String, x, CurrentDir As String
Const sn As String = "納指進捗表"
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
CurrentDir = CurDir
ChDrive myDir: ChDir myDir
fn = Dir(myDir & "*.xls")
Do While fn <> ""
temp = "'[" & fn & "]" & sn & "'!r1s3:r10000s3"
x = ExecuteExcel4Macro("count(if((" & temp & "<>"""")*(len(" & temp & ")<>8)," & temp & "))")
If x > 0 Then
ThisWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp)(2).Value = fn
End If
fn = Dir
Loop
ChDrive CurrentDir: ChDir CurrentDir
End Sub
ファイルが入っているフォルダは
N:\XXXXX\〔21〕ｼｽﾃﾑ\《18》ｼｽﾃﾑ\2014010010
というところになります。
（かもすけ） 2014/05/26(月) 15:46
> 実際確認したい列はS列なので
temp = "'[" & fn & "]" & sn & "'!r1c19:r10000c19" （seiya） 2014/05/26(月) 17:43
ご回答ありがとうございます！
そうでしたね、cは変えてはいけませんでしたね。ご指摘ありがとうございます。
こちらに書き換えてマクロを走らせたのですが、保存しているすべてのファイル名が
あがってしまいました。
具体的には、回答納期にはyyyymmddという8ｹﾀ数字が入っていてほしくて、m月d日や
yyyy/mm/ddと入っているのはNGで、そのファイル名は出てほしいという形です。
何度も申し訳ございません。
（かもすけ） 2014/05/28(水) 14:11
一番最初のJeraさんのコードは
tbl = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Offset(1).Row).Value
ってなっているので、データ行は2行目からの様に感じますが
temp = "'[" & fn & "]" & sn & "'!r1c19:r10000c19"
これだと、・・・・・・・・・・・・・~１行目からの範囲になっている様ですが。
また、
x = ExecuteExcel4Macro("count(if((" & temp & "<>"""")*(len(" & temp & ")<>8)," & temp & "))")
部分は、SUMPRODUCT関数にしてみてはどうでしょう？
x = ExecuteExcel4Macro("SUMPRODUCT((" & temp & "<>"""")*(len(" & temp & ")<>8))")
（HANA） 2014/06/03(火) 08:54
ご指摘、ならびにご提案ありがとうございました！
内容を変更してみたところ、無事マクロが起動しました！本当にありがとうございました。
またご協力いただきましたすべての皆様に感謝いたします。
ありがとうございました。
（かもすけ） 2014/06/06(金) 16:55
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.