『デスクトップフォルダ内EXCELファイルから文字取得』（たんたん）

はじめまして。

VBA触り始めた者ですが、ちょっと高度でどう作成していいのか、
分かりません。
どうかご教授よろしくお願いします。

希望の動き
　1.デスクトップフォルダにあるEXCELファイルを開く
　2.そのシート内に特定文字があればそれの1つ右のセル内の文字を
　　sheet1へ書き出す

というものです。

デスクトップ上のフォルダ名:発注依頼書
EXCEL:複数ある場合あり
特定文字:材料手配
特定文字はセルA10にあり、取得したい文字はその横(結合しているのでH10)
にあります。

可能であればsheet1への書き出しは･･･
A列･･･取得したEXCELファイル名
B列･･･取得したい文字
に書き出せれば、と思っております。


過去記事:20170116220914が近いと思われますが、
どこをどう改良すればいいのか･･･。

分かっていない状態で、ここに書いていますが、
どうぞよろしくお願いします。



＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
----
とりあえず、されたいことを整理するとこうなりますよね
 (1) デスクトップにある「発注依頼書」というフォルダの中にある
 (2)「●●.xls?」を片っ端から開いて
 (3)【シートが不明】のA10セルが「材料手配」となっていたら
 (4)【シートが不明】のH10セルをコピーして
 (5)「マクロを記述したブック」の「Sheet1」のうち
     A列・・・・・(4)を貼り付け
     B列・・・・・(2)で開いたブック名を記入
     C列・・・・・【シートが不明】のシート名を記入
 (6)開いたブックを閉じる
 (7)(1)のフォルダ内にある、「●●.xls?」全部で(2)〜(6)を繰り返す

＞VBA触り始めた者
とのことですから、一足飛びにやろうとしても混乱するように思いますので、
 （A）特定のフォルダにある「●●.xls?」を全部探す方法
 （B）（あらかじめ開いておいた）ブックの各シートを巡回し、A10セルの値を取得（チェック）する方法
 （C）ブック間でコピー＆ペーストをする方法
  (D)ブックを開く方法、閉じる方法

というように部品で考えてから、これらを合体する手順で調べてみてはどうでしょうか。

 (A)のヒント
http://officetanaka.net/excel/vba/tips/tips107.htm
http://officetanaka.net/excel/vba/file/file07.htm

 (B)のヒント
https://www.vba-ie.net/statement/foreachnext.php
https://programming-study.com/technology/vba-for-each/

 (C)のヒント
http://officetanaka.net/excel/vba/cell/cell09.htm

 (D)のヒント
http://officetanaka.net/excel/vba/file/file01.htm
http://officetanaka.net/excel/vba/file/file03.htm

（もこな２） 2019/02/25(月) 12:56
----
"発注依頼書" というフォルダ下に、更にサブフォルダが複数あって…、という状況でないならば、参照先の私のコードを使う必要性はなく、もこな２さんの案内に従って、Dir関数でコーディングすれば良いですよ。 それが基本的な方法です。

とりあえず、参考用。
 Sub test()
    Dim wk As Worksheet
    Dim cFiles As Variant
    Dim cPath As String
    Dim iR As Long
    Dim iw As Long
    Dim i As Long

    Application.ScreenUpdating = False
    Set wk = Sheets("Sheet1")
    wk.Cells.ClearContents

    cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\発注依頼書\"
    cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
    For i = 0 To UBound(cFiles) - 1
        If InStr(cFiles(i), "$") = 0 Then
            With Workbooks.Open(cFiles(i), False, True)
                With .Sheets(1)
                    If .Range("A10") = "材料手配" Then
                        iw = InStrRev(cFiles(i), "\")
                        iR = iR + 1
                        wk.Cells(iR, "A").Value = Mid(cFiles(i), iw + 1)
                        wk.Cells(iR, "B").Value = .Range("H10")
                    End If
                End With
                .Close False
            End With
        End If
    Next i

    Application.ScreenUpdating = True
 End Sub
（???） 2019/02/25(月) 15:02
----
もこな２さん

参考のヒントありがとうございます。
まだヒントをほぼコピーで持ってきてどんなんか試し中です。

Sub test1()
    Dim buf As String, cnt As Long
    Const Path As String = "C:\Users\test\Desktop\発注依頼書\"
    buf = Dir(Path & "*.xlsx")
    Do While buf <> ""
        cnt = cnt + 1
        Cells(cnt, 1) = buf
        buf = Dir()
        
        Dim MyR As Range 'オブジェクト変数にRangeを指定'
        Range("A20").Select
        For Each MyR In Selection   'Selection内のセルを操作対象とする'
            Worksheets("Sheet1").Range("H10").Copy Worksheets("Sheet2").Range("H10")
        Next MyR
        
    Loop
    MsgBox ("終了")
End Sub

まだ全然動けていません。
ファイル名取得で少し喜んでいる段階･･･。レベルがバレてしまう＞＜

まだまだ。
（たんたん） 2019/02/25(月) 15:35
----
Sheet1からSheet2にコピーするのではなく、開いたブックのどこかのシート（どこですか？）から、自ブックのSheet1にコピーですよね？ ブックを開く部分が無いようですよ。 
（???） 2019/02/25(月) 15:54
----
???さん

　大変遅くなり、申し訳ございません。
　???さんのコードで動き、そのデータの流れを追っているところです。
　VBAにコマンドを組み合わせており･･･思いつかないどころか、
　こんなこともできるのか！と。

　これで動きはできると思った中、もう1つ要件課題を言われ、
　思いつくコードを追記しました。(***↓↓↓以降)

  Sub test()
    Dim wk As Worksheet
    Dim cFiles As Variant
    Dim cPath As String
    Dim iR As Long
    Dim iw As Long
    Dim i As Long
    Dim d1   As String
    Dim dt1  As Date
    Dim dt2  As Date


    Application.ScreenUpdating = False
    Set wk = Sheets("Sheet1")
    wk.Cells.ClearContents

    cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\発注依頼書\"
    cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)
    For i = 0 To UBound(cFiles) - 1
        If InStr(cFiles(i), "$") = 0 Then
            With Workbooks.Open(cFiles(i), False, True)
                With .Sheets(1)
                    If .Range("A10") = "材料手配" Then'資材･建材在庫確認FLG
                        iw = InStrRev(cFiles(i), "\")
                        iR = iR + 1
                        wk.Cells(iR, "A").Value = Mid(cFiles(i), iw + 1)
                        wk.Cells(iR, "B").Value = .Range("H10")
                    End If
                    
                End With
'*** ↓↓↓
		d1 = .Range("I1") '格納資料の作成日付と当日以降の日付チェック(デグレ防止)

		dt1 = CDate(Format(d1, "yyyy/mm/dd"))
		dt2 = Date '当日日付

		If dt1 >= dt2 Then
		wk.Cells(5, 3).Value = dt1

	    Debug.Print "OK"
                .PrintOut
                '.Close False
                wk.PrintOut
  		Else

      	MsgBox ("日付がおかしいファイル有り！"), vbCritical
    	End If


                    
                    
                End With
                .Close False


            End With
        End If
    Next i

    Application.ScreenUpdating = True
    
 End Sub

当日より古い(過去)発注書は仮に発注依頼書フォルダに入っていても
印刷しないようにしたかったのですが、分からず。
分かる範囲で調べて過去日付があれば、メッセージを出すようにしました。

が、これでいくと過去の発注書は印刷しませんが、
当日より新しい発注書は印刷されてしまいます。
今はそのメッセージが出力すれば、発注依頼書フォルダ内を確認し、
不要分を取り除き、再度実行するように報知しています。

できれば、過去の発注書が入っていた場合は読み飛ばす
当日以降未来分のみを印刷するようにって可能でしょうか？

頼り切りで申し訳ございませんが、再度ご教授お願いできますでしょうか。
（たんたん） 2019/03/01(金) 19:07
----
d1が作成日付だとすると、d1とd2の大小関係判定が逆ではないですか？ それだけで目的を果たせるように思います。（d1の代入時、.Sheets(1)のWithが終わっているので、エラーになりそうですが？）

また、手入力された日付を使う方法以外に、ファイルの更新日時を使う方法と、ブックの最終保存日時を使う方法があります。 手入力だと入力忘れがあったりしないでしょうか？
（???） 2019/03/04(月) 09:04
----
???さん

　ご回答、ありがとうございます。

＞d1が作成日付だとすると、d1とd2の大小関係判定が逆ではないですか？
テストを行っているのですが、特にこれで大丈夫と思っています。

d1が作成日付(どうやら請求予定日らしい)
d2が当日日付　であるので
If dt1 >= dt2 Thenであり、当日以降未来分が出力OKとしたいので
　2/28    3/4 の場合は出力NG
　3/5　   3/5 の場合は出力OK
となります。

＞（d1の代入時、.Sheets(1)のWithが終わっているので、エラーになりそうですが？） 
発注依頼書フォルダ内に作成日付が2/28,3/4,3/5の3シートがあったとします。

これで実行した場合、
2/28,3/1作成日付分はNGのメッセージ出力し印刷はされませんが、
3/5作成日付分のデータは印刷されてしまいます。
Exit Subで抜ければいいのでしょうが、既に印刷がかかったものは印刷されてしまいます。


しかし、運用を考えるとNGがなければ印刷するの方がという声が出そうと懸念しています。
ただし、それにはどうすればというのが知識不足で分かりません。
よって今は過去請求予定日分(2/28,3/1分)を取り除いて再処理かけると展開しようとしています。

＞手入力だと入力忘れがあったりしないでしょうか？
d1に作成日付が入りますがここは経理部が入力しています。
ファイル更新日時/ブック保存日時でもと思いましたが、
実際は経理担当がコントロールしており、一概にファイル更新日時 = 作成日付
ではないようです。

（たんたん） 2019/03/05(火) 09:26
----
印刷日時を記録してはいかがでしょうか？ 請求予定日と当日だけの比較では、既に印刷済みか判断できませんから。（対象ブック内に持つか、印刷用マクロブックにファイル一覧表を作成し、ここに持つか…）
（???） 2019/03/05(火) 09:52
----
???さん

　初心者的発想かもしれませんが･･･
　1.まずは発注依頼書フォルダ内の各ブックを開いて日付チェック
　2.請求日付的に問題なければ、教えていただいているコードで印刷
　と2段階しか思いつきませんでした。

その上で〜

  Sub test()
    Dim wk As Worksheet
    Dim cFiles As Variant
    Dim cPath As String
    Dim iR As Long
    Dim iw As Long
    Dim i As Long
    Dim d1   As String
    Dim dt1  As Date
    Dim dt2  As Date

    Application.ScreenUpdating = False
    Set wk = Sheets("Sheet1")
    wk.Cells.ClearContents

    cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\発注依頼書\"
    cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.xls*""").StdOut().ReadAll(), vbNewLine)

'***お試し
Do While i < UBound(cFiles) - 1
        If InStr(cFiles(i), "$") = 0 Then
            With Workbooks.Open(cFiles(i), False, True)
                With .Sheets(1)
                

                d1 = .Range("H10") '発注依頼書の請求日付
                dt1 = CDate(Format(d1, "yyyy/mm/dd"))
                dt2 = Date '当日日付
                If dt1 < dt2 Then MsgBox ("日付がおかしいファイル有り！"), vbCritical

      
            End With
.Close False

            End With
        End If

    'Next i
    i = i + 1

Loop


i = 0
'***お試し終了

    For i = 0 To UBound(cFiles) - 1
        If InStr(cFiles(i), "$") = 0 Then
            With Workbooks.Open(cFiles(i), False, True)
                With .Sheets(1)
                    If .Range("A10") = "材料手配" Then'資材･建材在庫確認FLG
                        iw = InStrRev(cFiles(i), "\")
                        iR = iR + 1
                        wk.Cells(iR, "A").Value = Mid(cFiles(i), iw + 1)
                        wk.Cells(iR, "B").Value = .Range("H10")
                    End If

                End With
'*** ↓↓↓
		d1 = .Range("I1") '格納資料の作成日付と当日以降の日付チェック(デグレ防止)

		dt1 = CDate(Format(d1, "yyyy/mm/dd"))
		dt2 = Date '当日日付

		If dt1 >= dt2 Then
		wk.Cells(5, 3).Value = dt1

	    Debug.Print "OK"
                .PrintOut
                '.Close False
                wk.PrintOut
  		Else

      	MsgBox ("日付がおかしいファイル有り！"), vbCritical　'←ここがいるかどうか
    	End If

                End With
                .Close False

            End With
        End If
    Next i

    Application.ScreenUpdating = True

 End Sub

有識者から見ると、コードが汚いかもしれませんが
どうでしょうか？(逆質問ですいません)
（たんたん） 2019/03/05(火) 12:29
----
と書きましたが、一部修正と追記となります。

＜修正＞
修正前:Do While i < UBound(cFiles) - 1 
修正後;Do While i < UBound(cFiles)

＜追記＞
　Do While〜Loop内でNGがあれば処理を終わらせたいのですが、ここが分かりません。
(NGがあれば全てを印刷させないようにしたいため)
Loop抜けた直後にEndとするとそこで処理が終了してしまいますし･･･。

何かいい方法ありますでしょうか？

（たんたん） 2019/03/05(火) 12:49
----
駄目な点を列挙します。
 ・段付けが変。そのせいか、With文がひとつ多くないですか？ これ、動きますか？（回答者にデバッグさせないように）
 ネストが汚いソースは、人に見せてはいけません。
 ・ForループとWhileループ。やっていることは同じなのに、2つの命令を使うのは変。
 Whileループはミスすると無限ループする可能性があるので、この場合はForループに統一すべき。
 （それとも、Whileループを使わなければいけなかった理由があるのですか？）
 ・「お試し」部分で日付不正があるとMsgBox表示しますが、その後、そのまま印刷処理に流れるので、メッセージの意味なし。
 そもそも、このメッセージを見ても、どのファイルが不正だったのか判断できない。
（不正を見つけたら中断ならば、ブックをClose後、Exit Subすれば良いですが、複数のブックに日付不正がある可能性は無いのですか？）

改善案。
 ・日付判定だけでループさせず、「材料手配」判定と日付の抜き出しをまとめれば１つのループになるでしょう。
 ・日付情報と判定結果はMsgBox表示せず、C列以降にセットして最後までループを通す。そうすれば、一覧の中に判定結果が表示されるので、
 複数不正ファイルがあってもいちいち中断せず、1回で判るでしょう。
 ・このプロシジャではPrintOutは行わず、作成した一覧を元にループし、判定OKなものだけ全部印刷する別プロシジャを作成した方が、
 運用が楽になりませんか？
（???） 2019/03/05(火) 13:26
----
???さん

　色々ご指摘、ありがとうございます。

段付けについては今から修正します。
確かにどことどこをくくっているのか、迷いますね。
とりあえず、まずは動かすこと！という意識があるようでした。

For/Whileについてはあまり意識はしていませんでした。
自分の思いと検索でやりたい事でWhileが出てきて･･･。
無限ループまで意識していませんでした。ちょっと危なかったです。

日付不正時のMSG出力後について、フォルダ内全て確認し
本当はそこで終了させたいのですが･･･
全然分かっていないんで、今はエラーMSG出力させて処理を止めてしまう方向で。
エラーのあったファイル名は
If dt1 < dt2 Then MsgBox ("日付がおかしいファイル有り！" & vbLf & cFiles(i) & vbLf), vbCritical
これでファイル名は表示させようと思っています。

＞（不正を見つけたら中断ならば、ブックをClose後、Exit Subすれば良いですが、
＞複数のブックに日付不正がある可能性は無いのですか？）
そうですね、まさに複数ファイルあることが多いので、なかなか上手くいっていません。


（たんたん） 2019/03/05(火) 17:49
----
複数の日付不正対応は、改善案に書いた通りですので、考えてみてください。

余談ながら、While文が危ないよ〜、というのは、今回はループ内で i = i + 1 としてますよね。 例えばこの行を間違えて消してしまったりとか、プラストマイナスを間違えたとかすると、いつまでたっても抜ける条件が成立せず、無限ループに陥る訳です。

間違えなければ問題ないですし、心配ならループの内側にDoEventsを1行入れておけば、マクロを停止することができます。 Forループの場合、ループ回数に到達すれば抜けるので、ミスしても全然処理しないか、最後までループするかになるので、安全なのですよ。

また、テキストファイルを1行ずつ読み込む場合のように、何行あるか途中では判断できないような場合にはWhile文が有効なので、使いどころを考えましょう。
（???） 2019/03/05(火) 18:18
----
???さん

　何度もありがとうございます。
改善案については、まだまだ勉強とテストを繰り返さないと
理解できるには程遠く、もう少しお時間いただきます。

分かっていない中でのWhile文の無限ループに入ったときには
落ち着いて「Ctrl＋Pause」を押す事、覚えておきます。

今は動く！で喜んでいますが、次は使いどころを見極めて使えるよう
がんばります。
(内容に対する返信にはなってないかも･･･)

（たんたん） 2019/03/05(火) 19:38