マスターリストの検索一致の場合

Question

私がまとめたコードを変更しようとしていて、それを変換するのが少し難しいです。以前のコードでは、フォルダ内のファイルを調べ、そのファイルから名前を取り出し、それを使って正しいファイルであるかどうかを判断しました。私は現在、名前がファイル名ではなくセルにあるマスターリスト（1つのファイル）を実行しようとしています。

最初のuserformはfirstとlastの名前を要求し、ボタンはsearchと表示されます。

Private Sub search_Click() ' In userform1 

' Declare and set variables 
Dim fname As String, lname As String 
Dim Path As String, fCell As Range, fAdd As String 
Path = "C:\Master List.xlsx" 
fname = userform1.firstname_Search.Text 
lname = userform1.lastname_Search.Text 
' Store the name searched for 
With Worksheets("Sheet1") 
    .Range("A1") = fname 
    .Range("A2") = lname 
End With 

Workbooks.Open (Path) 

' Ensure the name searched for exists in the master list 
With Workbooks("Master List").Worksheets("Master List").Range("A:A") 
    Set fCell = .Find(fname) 
    If Not fCell Is Nothing And fCell = fname Then 
     ' Column A is first name, B is middle initial, C is last name, D is suffix, F is date of birth 
     If fCell.Offset(0, 2) = lname Then 
      userform2.firstname_Text.Text = fCell 
      userform2.middlename_Text.Text = fCell.Offset(0, 1) 
      userform2.lastname_Text.Text = Trim(fCell.Offset(0, 2) & " " & fCell.Offset(0, 3)) 
      userform2.dob_Text.Text = fCell.Offset(0, 5) 
      Unload Me 
      userform2.Show vbModeless 
      userform3.Label1.Caption = "Now that we have the information from " & fCell & "'s file, what would you like to do?" 
     Else 
      MsgBox ("I could not find a client by that name.") 
      Workbooks("Master List").Close False 
     End If 
    Else 
     MsgBox ("I could not find a client by that name.") 
     Workbooks("Master List").Close False 
    End If 
End With 

End Sub 

このセクションでは、正常に動作して表示され、入力された姓と名が一致する最初のエントリをプルアップします。この問題は、適切な人物がプルアップされているかどうかを判断するための関連情報を表示するため、2番目のユーザーフォームuserform2がプルアップされたときに発生しています。 first,middle,lastの名前とdate of birthとYesとNoボタンを表示します。 Noをクリックするうちに、Noをクリックすると、Noをクリックすると、2番目のNoは、次のように循環する必要があります（たとえば、3つのウィリアムジャクソンが表示されている場合は、をクリックする必要があります）。その名前の他のエントリが存在しないため、MsgBoxを提示する必要があります）。

問題は、最初の最後のサイクルを見つける方法が見つからないということです。No; Noが2回目にクリックされた場合、見つかった2番目のエントリを通過しません。私はこれが最初にSet fCell = .Find(fname)とSet fCell = .FindNext(fCell)のためであることを知っていますが、が何度もクリックされたセルを作ることの不足は、これを行う良い方法がありますか？

Private Sub no_Click() ' In userform2 

' Declare and set variables 
Dim fname As String, lname As String 
Dim Path As String, fCell As Range, fAdd As String 
Path = "C:\Master List.xlsx" 
With Workbooks("FirstWorkbook").Worksheets("Sheet1") 
    fname = .Range("A1") 
    lname = .Range("A2") 
End With 

' Ensure a client exists 
With Workbooks("Master List").Worksheets("Master List").Range("A:A") 
    Set fCell = .Find(fname) 
    Set fCell = .FindNext(fCell) 
    If Not fCell Is Nothing And fCell = fname Then 
     If fCell.Offset(0, 2) = lname Then 
      firstname_Text.Text = fCell 
      middlename_Text.Text = fCell.Offset(0, 1) 
      lastname_Text.Text = Trim(fCell.Offset(0, 2) & " " & fCell.Offset(0, 3)) 
      dob_Text.Text = fCell.Offset(0, 5) 
      userform3.Label1.Caption = "Now that we have the information from " & fCell & "'s file, what would you like to do?" 
      With Workbooks("FirstWorkbook").Worksheets("Sheet1") 
       .Range("A1") = fCell 
       .Range("A2") = fCell.Offset(0, 2) 
      End With 
     Else 
      MsgBox ("I could not find a client by that name.") 
      Workbooks("Master List").Close False 
     End If 
    Else 
     MsgBox ("I could not find a client by that name.") 
     Workbooks("Master List").Close False 
    End If 
End With 

End Sub 

1つのユーザーフォームを使用するよりよい方法、またはマスターリストを検索するためのより良い方法があります。この問題を解決するのに役立つ解決策、または正しい方向のポイントがあるので、私はそれを行うための別の方法を見ることができます。

Answer 1

Find関数をスタンドアロン関数に組み込み、検索値にすべての一致を返すことをお勧めします（下の例ではコレクションオブジェクトを返します）。その戻り値をフォームのグローバルフィールドに格納します。

再実行して検索するよりも、それは使用が第

Public Function FindAll(rng As Range, val As String) As Collection 
    Dim rv As New Collection, f As Range 
    Dim addr As String 

    Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _ 
     LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _ 
     SearchDirection:=xlNext, MatchCase:=False) 

    If Not f Is Nothing Then addr = f.Address() 

    Do Until f Is Nothing 
     rv.Add f 
     Set f = rng.FindNext(after:=f) 
     If f.Address() = addr Then Exit Do 
    Loop 

    Set FindAll = rv 
End Function 

Answer 2

をクリックするたびに私はしたいと思います（別の場所から始まる）このような関数の戻り値を循環する方がはるかに簡単ですすべてのフォルダとすべてのサブフォルダのすべてのファイルを一覧表示します。このリンクをチェックしてください。

http://www.learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/

ファイルをダウンロードしてください。それが行く方法です。すべてのパスとすべてのファイル名がExcelワークシートに表示されたら、すべての種類の比較や操作などを行うことができます。

Sub GetFilesInFolder(SourceFolderName As String) 

    '--- For Example:Folder Name= "D:\Folder Name\" 

    Dim FSO As Scripting.FileSystemObject 
    Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder 
    Dim FileItem As Scripting.File 

     Set FSO = New Scripting.FileSystemObject 
     Set SourceFolder = FSO.GetFolder(SourceFolderName) 

     '--- This is for displaying, whereever you want can be configured 

     r = 14 
     For Each FileItem In SourceFolder.Files 
      Cells(r, 2).Formula = r - 13 
      Cells(r, 3).Formula = FileItem.Name 
      Cells(r, 4).Formula = FileItem.Path 
      Cells(r, 5).Formula = FileItem.Size 
      Cells(r, 6).Formula = FileItem.Type 
      Cells(r, 7).Formula = FileItem.DateLastModified 
      Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)" 

      r = r + 1 ' next row number 
     Next FileItem 

     Set FileItem = Nothing 
     Set SourceFolder = Nothing 
     Set FSO = Nothing 
    End Sub 


Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean) 

'--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No 

Dim FSO As Scripting.FileSystemObject 
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder 
Dim FileItem As Scripting.File 
'Dim r As Long 
    Set FSO = New Scripting.FileSystemObject 
    Set SourceFolder = FSO.GetFolder(SourceFolderName) 

    '--- This is for displaying, whereever you want can be configured 

    r = 14 
    For Each FileItem In SourceFolder.Files 
     Cells(r, 2).Formula = r - 13 
     Cells(r, 3).Formula = FileItem.Name 
     Cells(r, 4).Formula = FileItem.Path 
     Cells(r, 5).Formula = FileItem.Size 
     Cells(r, 6).Formula = FileItem.Type 
     Cells(r, 7).Formula = FileItem.DateLastModified 
     Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)" 

     r = r + 1 ' next row number 
    Next FileItem 

    '--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling. 

    If Subfolders = True Then 
     For Each SubFolder In SourceFolder.Subfolders 
      ListFilesInFolder SubFolder.Path, True 
     Next SubFolder 
    End If 

    Set FileItem = Nothing 
    Set SourceFolder = Nothing 
    Set FSO = Nothing 
End Sub