Using a input box to Copy and paste in macro

[randolphoralph]

Using a input box to Copy and Paste

I am needing a macro that will use a input box to ask for user to enter a date to look for in Column A1:A100 on Sheet1 and if the date is found copy part of the row...for example if date is found in A5 the macro would copy B5:F5 then activate Sheet2 and look in Column B1:B100 for the same date and paste information...for example if same date found in B2 then information would paste into C2:G2.


Sheet1
A_______ B_C_D_E_F
10/1/2009 1 1 1 1 1
10/2/2009 2 2 2 2 2


Sheet2 before running macro

A________B_C_D_E_F_G
10/3/2009
10/1/2009
10/4/2009

Sheet2 after running macro

A_B_________C_D_E_F_G
__10/3/2009
__10/1/2009 1 1 1 1 1 1
__10/4/2009


I have found the code below but was not sure how to alter it to make it work for my situation.

Sub btnFind_Click()
Dim strLastRow As String
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet
Dim rngtest As String
Application.ScreenUpdating = False
Set wSht = Worksheets("Sheet2")
strToFind = InputBox("Enter the date to find")
With ActiveSheet.Range("A1:A100")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
strLastRow = Worksheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row + 1
rngC.EntireRow.Copy wSht.Cells(strLastRow, 1)
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
MsgBox ("Finished")
End Sub

 

[dscg]

Try something like this which is more specific to your ranges and avoids any loops.

Sub DateMatcher()
Dim strToFind As String
Dim FndIn1 As Long
Dim FndIn2 As Long
Dim WS1 As Worksheet
Dim WS2 As Worksheet

Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")

strToFind = InputBox("Enter the date to find")

On Error GoTo ErrorHandler
FndIn1 = WS1.Range("A1:A100").Find(what:=strToFind, LookAt:=xlPart).row
FndIn2 = WS2.Range("B1:B100").Find(what:=strToFind, LookAt:=xlPart).row
On Error GoTo 0

WS1.Range("B" & FndIn1 & ":F" & FndIn1).Copy WS2.Range("C" & FndIn2 & ":G" & FndIn2)

Set WS1 = Nothing
Set WS2 = Nothing

Exit Sub
ErrorHandler: MsgBox ("No match was found, please try again.")
End Sub

 

[randolphoralph]

That does exactly what I need. Thank you for your help on that.