Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 8.1 Pro : Excel 2007)
フォルダ検索+値検索
投稿日時: 17/05/15 14:49:55
投稿者: FILETUBE

 何度もお世話になりありがとうございます。
 
度重なる質問で申し訳ありませんが、どうぞよろしくお願いします。
 
a.xlsm
B列(番号) C列
AA-1
BB-2
DD-5
とあります。a.xlsmにボタンを配置し
クリックすると
 
C:\Aのフォルダ内のすべてのブックを検索にいきます。
 
Aフォルダ内
bb.xls
cc.xls
dd.xls
レイアウトは全て同じです。
 
C列(番号) D列
AA-12 123
BB-15 456
CC-21 789
DD-31 101
という内容になっています。
 
フォルダのブックを検索し、値を検索し番号が一致したら
a.xlsmのC列に一致したD列の値をセットし、次のブックは
検索しないで、次の番号の処理を行いたいのです。
しかも番号一致の比較はおのおのハイフンから左の文字で比較したいのです。
 
セット結果は
a.xlsm
B列(番号) C列
AA-1 123
BB-2 456
DD-5 101
のようにしたいのです。
 
 
Sub ボタン1_Click()
    Dim r As Long
    For r = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
        EachRow r
  Next r
End Sub
 
Private Sub EachRow(ByVal r As Long)
 
  Dim str As String
  str = Cells(r, 2)
     
  Const DIR_PATH = "C:\test\ZAIKO"
  Dim fl_name As String
 
  fl_name = Dir(DIR_PATH & "\*.xls*")
  If fl_name = "" Then
    MsgBox "Excelファイルがありません。"
    Exit Sub
  End If
 
  Application.DisplayAlerts = False
  Dim bk As Workbook
   
  Do
    Workbooks.Open _
        FileName:=DIR_PATH & "\" & fl_name
         
        fl_name = Dir
  Loop Until fl_name = ""
  
  Application.DisplayAlerts = True
 
End Sub
 
上記のように
フォルダ内のブックの一覧の取得まではコーディングしましたが
この後の処理方法をわかる方おられましたら、教えて頂けないでしょうか。
 
大変申し訳ありませんが、よろしくお願いします。
 
 
 

回答
投稿日時: 17/05/15 15:02:59
投稿者: WinArrow
投稿者のウェブサイトに移動

説明が不十分です。
 
検索するには、検索キーと検索場所(検索範囲)が必要です。
 
そのあたりが不明確です。
 
回答者は、あなたのPCの画面は見えませんから
文章で見えるように位書いてもらわないと、アドバイスができない。
 
もう少し、おちついて、できるだけ箇条書きに
状況を説明しましょう。
 

回答
投稿日時: 17/05/15 15:20:48
投稿者: WinArrow
投稿者のウェブサイトに移動

追加のコメント
 
Do〜Loopの中で、ブックを開いているが、
開いたままではなく、キチンと閉じましょう。

投稿日時: 17/05/15 15:36:54
投稿者: FILETUBE

 回答ありがとうございます。
 
Sub ボタン1_Click()
   
 Dim wb As Workbook
 Dim thisbook As Workbook
 Dim c As Range
 Dim r As Range
 Dim iRow As Long
 
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Set wb = Workbooks.Open("C:\test\A\bb.xls ")
 Set thisbook = ThisWorkbook
 
 iRow = thisbook.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
  
 For Each r In thisbook.Sheets(1).Range("B2:B" & iRow)
  Set c = wb.Sheets(1).Cells.Find(what:=r.Value, LookAt:=xlWhole)
  If Not c Is Nothing Then
  
    r.Offset(0, 1).Value = c.Offset(0, 1).Value
 
  End If
  Set c = Nothing
 Next
 
 wb.Close (False)
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 
End Sub
 
前回の質問を参考に特定のブックを参照して、完全一致の値の取得は上記のコードでできるのですが、
 
問題点
1.検索はC:\test\Aのフォルダ内のすべてのブックを検索対象としたい。但し一度処理を
  行ったらその番号の処理は終了としたい。
 
 
2.番号一致のチェックは各々ハイフンの左側の文字で行いたい。
 
まずは、フォルダ内のブックの検索と、そのブックの処理の仕方がわからないのです。
大変申し訳ありませんが、よろしくお願いします。
 

投稿日時: 17/05/15 15:41:30
投稿者: FILETUBE

 追記になります。
 
検索キーは
a.xlsm の B列(番号)の値で
 
検索範囲は C:\test\Aのフォルダ内のすべてのブックを対象とします。
(1回セットしたらその番号は終了)
 
どうぞよろしくお願いします。

回答
投稿日時: 17/05/15 22:11:34
投稿者: i-brown

今回はサンプルコードのみです。Scripting.Dictionaryオブジェクトを使って、予め全てのファイル名を取得し、使用するたびに削除していけば、「既に使ったものを除外」することができます。
全体の順次検索はFor Eachを使い、DictionaryのKeysコレクションを順次探索すると良いでしょう。
 
https://msdn.microsoft.com/ja-jp/library/cc428065.aspx
 

Option Explicit

' 参照設定でMicrosoft Scripting Libraryを追加すること
Private dic As New Scripting.Dictionary

Sub Test()
    Const TargetDir As String = "C:\A\"
    Dim filename As String
    filename = Dir(TargetDir & "*.xlsx")
    
    Do
        dic.Add filename, Empty
        Dir
    Loop While filename <> ""
End Sub

Sub Test1()
    ' 検索
    Dim v As Variant
    v = dic.Item("abc.xlsx")
    
    ' 削除
    dic.Remove ("abc.xlsx")
End Sub

-で区切るのはLeftとInstrを使えばできます。

投稿日時: 17/05/16 11:15:28
投稿者: FILETUBE

  毎回ありがとうございます。
 
早速、試してみているのですが
dic.Add filename, Empty のところでオブジェクトが必要ですのエラーになります。
 
a.xlsm の B列(番号)の値で
検索範囲 C:\test\Aのフォルダ内のすべてのブックを対象とし
a.xlsmのC列に一致したブックのD列の値をa.xlsmにセットしたいのですが
フォルダのブックの検索+そのブック内の値の検索とセットの組み合わせ処理を
今一度、教えて頂けないでしょうか。
 
どうぞ、よろしくお願いします。
 
 
 

回答
投稿日時: 17/05/17 00:22:40
投稿者: i-brown

Private dic As New Scripting.Dictionary

でNewを書いていますか?
 
投稿者は初心者の方かと思い、2回ほど動くコードを提供しましたが、要件定義とエラー報告のみの投稿がが続くので、自力でコードを書く意思がないと判断してこれ以上の助言は差し控えます。
困り度「高」を連続で投稿していますが、掲示板の善意の回答者にコーティング作業を丸投げしようとしていませんか? 投稿時間とOSのバージョンから業務利用を疑っています。

投稿日時: 17/05/17 16:45:53
投稿者: FILETUBE

 厳しいご指摘ありがとうございます。
 
フォルダ内のブックの検索と値の検索の組み合わせが
手も足もでず、このような投稿ですいませんでした。

回答
投稿日時: 17/05/17 17:05:48
投稿者: sk

引用:
Aフォルダ内
bb.xls
cc.xls
dd.xls
レイアウトは全て同じです。
  
C列(番号) D列
AA-12 123
BB-15 456
CC-21 789
DD-31 101
という内容になっています。

引用:
しかも番号一致の比較はおのおのハイフンから左の文字で比較したいのです。

・A フォルダ内の複数のブック同士で、
 C 列の値に含まれる検索キー(ハイフンより左の文字列)が
 競合しているケースは存在しないものと見なしてもよいのか。
 
引用:
フォルダのブックを検索し、値を検索し番号が一致したら
a.xlsmのC列に一致したD列の値をセットし、次のブックは
検索しないで、次の番号の処理を行いたいのです。

・仮に複数のブック同士で検索キーが競合している場合、
 それらのうちどのブックを先に検索したかによって
 a.xlsm の C 列に出力される値が異なってしまう(正しくない)
 ケースが生じてしまいかねない。
 もし、ブックの検索順に関するルールが規定されているなら、
 それは具体的にどのようなものなのか。
 
その辺りの細かい仕様を整理する方が先決かと。

投稿日時: 17/05/17 18:52:15
投稿者: FILETUBE

 回答ありがとうございます。
どのブックをみてもC列で一致すれば問題ありません。
但し効率からいうと更新日が新しいブックから見て行った方がよいのですが。
 
フォルダの検索はDIRか、Filesystemobjectのどちらがいいのか
 
どのようにセット元のブックと検索したブックを扱っていくのか
模索しています。
 
 

回答
投稿日時: 17/05/17 21:40:16
投稿者: WinArrow
投稿者のウェブサイトに移動

>フォルダの検索はDIRか、Filesystemobjectのどちらがいいのか
 
どちらも「新しい更新日から」は無理です。
 
Filesystemobjectで最終更新日を取得し、並べ替えすればできます。
 

回答
投稿日時: 17/05/17 23:27:11
投稿者: simple

時間が空いたのでトライしてみました。
 
「比較処理」プロシージャーは一度も動かしていないので、怪しいです。
仕様を誤解しているかもしれません。
どうぞ、そちらで検証確認してください。
効率も一切考慮していません。
なお、修正依頼には一切応じません。
十分なヒントになっているはずですから。
修正はそちらでお願いします。
 
なお、testプロシージャは当方で確認ずみです。
その、フォルダには xlsファイルだけが入っている前提です。
 

Sub test()
    Dim fso As Object
    Dim sl As Object
    Dim f As Object
    Dim t As String
    Dim k As Long
    Dim pathname As String

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sl = CreateObject("System.Collections.SortedList")

    '指定フォルダからファイル名と更新年月日時刻を SortedListに格納
    For Each f In fso.GetFolder("D:\MyDocuments\201705").Files  '■■修正のこと
        t = fso.GetFile(f.Path).DateLastModified
        sl.Add t, f.Path
    Next

    '更新年月日時刻の新しいものから順に取り出して、比較処理を行う。
    For k = sl.Count - 1 To 0 Step -1
        Call 比較処理(sl.getbyindex(k)) '比較処理
    Next
End Sub

Function 比較処理(pathname As String)
    Dim dic     As Object
    Dim wb      As Workbook
    Dim ws      As Worksheet
    Dim thisWs  As Worksheet
    Dim k       As Long
    Dim s       As String
    Dim s2      As String
    
    'C:\Aフォルダ内のファイルを開いてシートの情報をdictionaryに読み込む
    Set dic = CreateObject("Scripting.Dictionary")
    Set wb = Workbooks.Open(pathname)
    Set ws = wb.Sheets(1)
    For k = 1 To ws.Cells(Rows.Count, "C").End(xlUp).Row
        s = ws.Cells(k, "C").Value
        s = Split(s, "-")(0)
        dic(s) = ws.Cells(k, "D")
    Next

    '自身のシートをC:\Aフォルダ内のファイルのシートとを比較して、
    '自身のシートを更新する
    Set thisWs = ThisWorkbook.Worksheets(1)
    For k = 1 To thisWs.Cells(Rows.Count, "B").End(xlUp).Row
        s = thisWs.Cells(k, "C").Value
        If s = "" Then
            s2 = thisWs.Cells(k, "B").Value
            s2 = Split(s2, "-")(0)
            thisWs.Cells(k, "C").Value = dic(s2)
        End If
    Next
    wb.Close False
End Function

投稿日時: 17/05/18 18:51:57
投稿者: FILETUBE

 大変丁寧な回答ありがとうございます。
厳しいご指摘もあり,なかば諦めていたのですが
本当にありがとうございます。
環境が無いので、早速明日検証してみたいと思います。

投稿日時: 17/05/19 19:03:25
投稿者: FILETUBE

こんばんは。
しかし凄いですね。正しくセット出来ました。
このような事が出来るまでに何年かかるのでしょうか。
 
最後にもう1点だけお聞きしたいのですが
このプログラムでAフォルダ内のブックを検索処理していると
毎回、aa.xlsを変更し、保存する必要がなければ
読み取り専用で開いてください。
読み取り専用で開きますか?
 
のメッセージが毎回出てきます。
これを出なくする事はできますか?
 
宜しくお願いします。

回答
投稿日時: 17/05/19 22:47:53
投稿者: simple

質問に対する答えは次のとおりです。

    Application.DisplayAlerts = False
    ' ファイルを開く動作をここに。
    Application.DisplayAlerts = True
のようにしてみて下さい。
 
-------------
以下、少し耳の痛い話になるかもしれません。
 
(1)コードを貰いっぱなしにしないで下さい。
 
提示されたコードを理解しようとしていますか?
希望を出して、そのコードをもらうだけだと寂しいと思いますよ。
他のかたもおっしゃっているように、
そうしたスタンスは回答者には歓迎されません。
なぜなら、それは相手を単に道具と思っているわけですから。
 
コードをポンと出されてラッキーと思うかも知れませんが、
それを自分のものにする機会を得たと考えて欲しいわけです。
そういう意味で、不明なところは質問があってしかるべきなんですね。
(出して置いて勝手な言い分かも知れませんが)
 
例えば、SortedListって何か理解していますか?
keyとValueの組み合わせを記憶するのですが、
追加するたびに、keyで見て順序づける処理が実行されることになっています。
そういうものなんですね。
 
(2)ご自分でも是非トライして下さい。
 
SortedListは便利ではあるけれど、VBAの外部のツールです。
もしこれを使わないとすれば、
シートにパス名と更新年月日時刻を二つの列に書込み、
年月日時刻でソートすれば、
新しい順にファイルを処理していくことは可能です。
こうしたことにもチャレンジして欲しいわけです。
(最初はこうしたソートを学ぶ必要があったかもしれません。)
 
私は前のスレッドをよく読んでいなかったですが、
その延長線上でなんとかなったようにも思います。
それほどのジャンプがあるようなものではないと思います。
ご自分にとってはどんな点が障害になっていたのか、
そこをどう対応しているのか、
よく観察していただきたいですね。
 
VBAなどのツールは、自分で作るような方向に考えなければ、
ほんとうのところ活用できるようなことにならないと思います。
希望の提示 + もらったコードのテスト
ということではなく、
少しでもコードに食いついて行って欲しいと思います。

投稿日時: 17/05/20 08:10:00
投稿者: FILETUBE

 色々とありがとうございました。
ご指摘の通りだと思います。
 
周りに聞ける人もいなく、申し訳ありませんでした。