範囲内のテキストを検索し、テキストを含むすべての行を表示する - VBA

Question

誰かが次のように私を助けることができる場合、私は非常に感謝される：

私は（テキストボックスを使用して）テキストを検索したいですで非常に大きなデータベースです。 （例えば：Ironを検索する）。私が期待している結果は、「赤い鉄」、「鉄の灰色」、「非常に長い鉄」+行全体を別のシート（テキストボックス名）にコピーして、範囲（D2：J）。 D1、E1、F1、G1、H1、I1、J1はサプライヤです。可能であれば、サプライヤ名と最低価格をmsgboxに表示したいと思っています。

範囲A：Aで検索したいですか？

誰でも私にこれを手伝ってもらえますか？

多くのおかげで、あなたはどんな自分でコーディングを試していませんでした場合は、起動するのに役立つ N.

Answer 1

カップルの事...

0.1）あなたは入力に自分でユーザーフォームを与えることができます（あなたは自分でUserformを作ることができるはずです）。あなたは（場合には、各パートの複数のマクロを記述）を介してそれを運ぶことができますので、コードの外でその用語を保存することを確認します：

Public burp as Text 
Sub 
    Set burp = Userform(1).Textbox(1).Value 'Will need to tweak 
End Sub 

Sub NameOfNextSub() 

0.2）私は検索機能で多くをプレイしていません、しかし、ループとマッチするところであなたが欲しいものに似た何かをしました。一致がある場合、それは別のシートの最後

Dim LR as Long 
LR = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row 

For i = 1 to LR 
    If IsError(WorkSheetFunction.Match(*burp*,cells(i,2)),0)>0 Then 
     Sheets("Sheet1").Row(i).Copy 
     Sheets("Sheet2").Row(i).PasteSpecial xlPasteValues 
     Else: 
     End If 
Next i 
Delete_Empty_Rows 'runs macro named "Delete_Empty_Rows" 

に内マッチした行を貼り付けGoogleは、空行を削除...あなたはそれをさまざまな方法をやって、ヒットのトンを取得する必要があります。あなたに最高の気分を選んでください。シート2上で実行されていることを確認します。

これはかなり怠惰なやり方ですが、うまくいくでしょう。

.3）フィルタシート2は、コストがかかっている列、xlAscendingに基づいています。もう一度、その上で迅速にGoogle。あなたの最低価格は一番上の行になります知っている、とあなたが列を知っているので、あなたがメッセージボックスには、そのセルには何が表示されるまで表示することができ

Columns("A:C").Sort key1:=Range("C2"), _ 
    order1:=xlAscending, header:=xlNo 

0.4）：次のようになります

MsgBox "Lowest price: "&Cells(1,4) 

これで、VBAで必要なコードを作成できるようになります。

Answer 2

`Private Sub SearchCommandButton_Click() 
`Dim searchitem As Variant 
`Dim lr As Long 
`Dim WSNew As Worksheet 
`Dim sheetname As String 

`Set searchitem = SearchUserForm.TextBox1.Value 
`lr = Cells(Sheets("GC").Rows.Count, 1).End(xlUp).Row 
`For i = 1 To lr 
`If IsError(WorksheetFunction.Match(searchitem, Cells(i, 2)), 0) > 0 Then 
`Sheets("GC").Row(i).Copy 
`Else 
`Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index)) 

    sheetname = searchitem 

    On Error Resume Next 

    WSNew.Name = sheetname 
    If Err.Number > 0 Then 
     MsgBox "We cannot match the search: " & WSNew.Name & _ 
      " Please try again" & _ 
      " Sheet already exist!" & _ 
      " The sheet name cannot contain this!" 
     Err.Clear 
    End If 
    On Error GoTo 0 

    With WSNew.Range("A1") 

     .PasteSpecial Paste:=8 
     .PasteSpecial xlPasteValues 
     .PasteSpecial xlPasteFormats 
     Application.CutCopyMode = False 
     .Select 
    End With 

End If 

End Subの `

Answer 3

私は別のコードを試してみました。これは、私がコピーを探しているテキストを特定し、既存のシートに貼り付けることです。マクロの先頭にある内容をクリアします。私は次に何をしようとしている何

`Private Sub SearchCommandButton_Click() 
Dim rFind As Range 
Dim rCopy As Range 
Dim strSearch As String 
Dim sFirstAddress As String 
Dim destsh As Worksheet 

Sheets("comparelist").Activate 
Sheets("comparelist").Range("A2:AA200").ClearContents 
strSearch = TextBox1.Value 
Set rCopy = Nothing 

Application.ScreenUpdating = False 

With Sheets("GC").Columns("A:A") 
Set rFind = .Find(strSearch, LookIn:=xlValues, Lookat:=xlPart,SearchDirection:=xlNext, MatchCase:=False) 
If Not rFind Is Nothing Then sFirstAddress = rFind.Address 
    Do 
     If rCopy Is Nothing Then 
      Set rCopy = rFind 
     Else 
      Set rCopy = Application.Union(rCopy, rFind) 
     End If 
     Set rFind = .FindNext(rFind) 
    Loop While Not rFind Is Nothing And rFind.Address <> sFirstAddress 

    rCopy.EntireRow.Copy 
    Sheets("comparelist").Activate 
    Sheets("comparelist").Range("A2").Select 
ActiveSheet.Paste 
Application.CutCopyMode = False 
Application.ScreenUpdating = True 
Unload Me 
Sheets("comparelist").Range("A1").Select 

End If 
End With 
End Sub 

は、最低は黄色行きと最大値は、各項目について、赤行くために、列D、I、NとRの値を比較することです。誰でも助けることができますか？

多くの感謝！ N.