ユーザーフォームの検索と更新

Question

私はこのコードをVBA検索ユーザーフォームでオンラインで見つけました。

ここに示した結果には、アドレスのみを入力するのではなく、見つかったセル行の他の列のデータが含まれるように修正したいと考えています。

最終的には、これらのセルの値をユーザーフォーム自体から変更することができます。だから私は特定の行を検索し、テーブルを更新することができます。

ここでは、コードです：

Private Sub TextBox_Find_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 
'Calls the FindAllMatches routine as user types text in the textbox 

    Call FindAllMatches 

End Sub 

Private Sub Label_ClearFind_Click() 
'Clears the find text box and sets focus 

    Me.TextBox_Find.Text = "" 
    Me.TextBox_Find.SetFocus 

End Sub 

Sub FindAllMatches() 
'Find all matches on activesheet 
'Called by: TextBox_Find_KeyUp event 

Dim SearchRange As Range 
Dim FindWhat As Variant 
Dim FoundCells As Range 
Dim FoundCell As Range 
Dim arrResults() As Variant 
Dim lFound As Long 
Dim lSearchCol As Long 
Dim lLastRow As Long 

    If Len(f_FindAll.TextBox_Find.Value) > 1 Then 'Do search if text in find box is longer than 1 character. 

     Set SearchRange = ActiveSheet.UsedRange.Cells 

     FindWhat = f_FindAll.TextBox_Find.Value 
     'Calls the FindAll function 
     Set FoundCells = FindAll(SearchRange:=SearchRange, _ 
           FindWhat:=FindWhat, _ 
           LookIn:=xlValues, _ 
           LookAt:=xlPart, _ 
           SearchOrder:=xlByColumns, _ 
           MatchCase:=False, _ 
           BeginsWith:=vbNullString, _ 
           EndsWith:=vbNullString, _ 
           BeginEndCompare:=vbTextCompare) 
     If FoundCells Is Nothing Then 
      ReDim arrResults(1 To 1, 1 To 2) 
      arrResults(1, 1) = "No Results" 
     Else 
      'Add results of FindAll to an array 
      ReDim arrResults(1 To FoundCells.Count, 1 To 2) 
      lFound = 1 
      For Each FoundCell In FoundCells 
       arrResults(lFound, 1) = FoundCell.Value 
       arrResults(lFound, 2) = FoundCell.Address 
       lFound = lFound + 1 
      Next FoundCell 
     End If 

     'Populate the listbox with the array 
     Me.ListBox_Results.List = arrResults 

    Else 
     Me.ListBox_Results.Clear 
    End If 

End Sub 

Private Sub ListBox_Results_Click() 
'Go to selection on sheet when result is clicked 

Dim strAddress As String 
Dim l As Long 

    For l = 0 To ListBox_Results.ListCount 
     If ListBox_Results.Selected(l) = True Then 
      strAddress = ListBox_Results.List(l, 1) 
      ActiveSheet.Range(strAddress).Select 
      GoTo EndLoop 
     End If 
    Next l 

EndLoop: 

End Sub 

Private Sub CommandButton_Close_Click() 
'Close the userform 

    Unload Me 

End Sub 

Answer 1

例えばデータの4つの列のためには、4にColumnCountを設定し、以下のようにあなたのコードを編集するフォームのリストボックスを編集し、：

'.... 
    If FoundCells Is Nothing Then 
     ReDim arrResults(1 To 1, 1 To 4) '<<<edit 
     arrResults(1, 1) = "No Results" 
    Else 
     'Add results of FindAll to an array 
     ReDim arrResults(1 To FoundCells.Count, 1 To 4) '<<<edit 
     lFound = 1 
     For Each FoundCell In FoundCells 
      arrResults(lFound, 1) = FoundCell.Value 
      arrResults(lFound, 2) = FoundCell.Address 
      'EDIT: adding two new columns 
      arrResults(lFound, 3) = FoundCell.EntireRow.Cells(4).Value 
      arrResults(lFound, 4) = FoundCell.EntireRow.Cells(5).Value 

      lFound = lFound + 1 
     Next FoundCell 
    End If 

    'Populate the listbox with the array 
    Me.ListBox_Results.List = arrResults 
    '....