Use a form to lookup a value and copy the row to another worksheet

[LoriD]

Hello. I am hoping someone can help me with this. I have a daily worksheet extracting a large amount of data (potentially 200K rows) on Sheet1. This range will vary daily. I would like to have a user form on Sheet2 which the user would input the value they wish to look up. This value could be found on Sheet1 in either column A or B. I would then like to have the row containing that value, copied over to Sheet2 with the user form, They would then enter the next lookup value using the form, and the data for that record on Sheet1 would get copied in underneath on Sheet2 until they are finished. Can this be accomplished? I am really not sure where to start.

 

[dmt32]

Hi,
if you are searching for single value then probably a simple inputbox to enter search value is all that is needed

Place following code in a STANDARD module & see if this will doi what you want

Sub FindValue()
    Dim Search      As Variant
    Dim FoundCell   As Range
    Dim i           As Long
    Dim Counter     As String
    Dim SearchSheet As Worksheet, DestSheet As Worksheet
   
    Const strPrompt  As String = "Enter Search Value"
   
    With ThisWorkbook
        Set SearchSheet = .Worksheets("Sheet1")
        Set DestSheet = .Worksheets("Sheet2")
    End With
   
    Do
        Search = InputBox(strPrompt & Counter, "Search")
        'cancel pressed
        If StrPtr(Search) = 0 Then Exit Sub
       
        If Len(Search) > 0 Then
            Set FoundCell = SearchSheet.Range("A:B").Find(Search, LookIn:=xlValues, lookat:=xlWhole)
            If Not FoundCell Is Nothing Then
                'copy row to destination sheet
                FoundCell.EntireRow.Copy DestSheet.Range("A" & DestSheet.Rows.Count).End(xlUp).Offset(1)
                'diplay counter
                i = i + 1
                Counter = Chr(10) & Chr(10) & i & " Record(s) Copied"
            Else
                'inform user
                MsgBox Search & Chr(10) & "Record Not Found", 48, "Not Found"
               
            End If
        End If
        Set FoundCell = Nothing
    Loop
   
End Sub

Dave

 

[LoriD]

Dave this works great, and thank you so much! I realize while working with this that sometimes, there may be multiple records for the lookup value. Is there a way to modufy this to copy over every record found for that value?

 

[dmt32]

Is there a way to modufy this to copy over every record found for that value?

Hi
see if this update to the code does what you want

Sub FindValue()
    Dim Search      As Variant
    Dim FoundCell   As Range
    Dim i           As Long
    Dim Counter     As String, FirstAddress As String
    Dim SearchSheet As Worksheet, DestSheet As Worksheet
    
    Const strPrompt  As String = "Enter Search Value"
    
    With ThisWorkbook
        Set SearchSheet = .Worksheets("Sheet1")
        Set DestSheet = .Worksheets("Sheet2")
    End With
    
    Do
        Search = InputBox(strPrompt & Counter, "Search")
        'cancel pressed
        If StrPtr(Search) = 0 Then Exit Sub
        
        If Len(Search) > 0 Then
            Set FoundCell = SearchSheet.Range("A:B").Find(Search, LookIn:=xlValues, lookat:=xlWhole)
            If Not FoundCell Is Nothing Then
                Application.ScreenUpdating = False
                FirstAddress = FoundCell.Address
                Do
                    'copy row to destination sheet
                    FoundCell.EntireRow.Copy DestSheet.Range("A" & DestSheet.Rows.Count).End(xlUp).Offset(1)
                    'diplay counter
                    i = i + 1
                    Counter = Chr(10) & Chr(10) & i & " Record(s) Copied"
                    'find next match
                    Set FoundCell = SearchSheet.Range("A:B").FindNext(FoundCell)
                Loop While FirstAddress <> FoundCell.Address
            Else
                'inform user
                MsgBox Search & Chr(10) & "Record Not Found", 48, "Not Found"
                
            End If
        End If
        Set FoundCell = Nothing
        Application.ScreenUpdating = True
    Loop
    
End Sub

Dave

 

[LoriD]

Perfect! Thank you Dave.

 

[dmt32]

Perfect! Thank you Dave.

most welcome & appreciate your feedback

Dave

 

[LoriD]

I am having one more problem Dave. It doesn't work when I copy the code to my Personal.xlsx. Since they will be exporting a new file daily I was hoping to place the module in their Personal.xlsx

 

[LoriD]

Please disregard, I figured it out, and thanks again
.