Search and copy macro

jameshunt83

Board Regular
Joined
Oct 2, 2010
Messages
149
I have a worksheet called "1.xlsx". I have an active x form button on this sheet.
When this button is clicked I need it to open a second workbook called "2.xlsx". In cell A1 of "1.xlsx" I have a value. I need the macro to look which line in "2.xlsx" this value appears in column A and then copy the value in column B of this to "1.xlsx" cell A2 and also copy the value on that row in column C to "1.xlsx" cell A6.

The value in A1 will only appear on one line in the second workbook

Help greatly appreciated!
 

Some videos you may like

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

Colton

Board Regular
Joined
Jan 16, 2010
Messages
87
File Location will need to be changed (Highlighted in Red).
Your filename (1.xlsx) will need to be changed to 1.xlsm when code is added.

Code:
Private Sub CommandButton1_Click()

    Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, rSearch As Range
    Dim RowFind As Long
    Dim Lookup As Variant

    Application.ScreenUpdating = False

    Workbooks.Open Filename:="[COLOR="Red"]C:\2.xlsx[/COLOR]"

    Set Rng1 = Workbooks("2.xlsx").Worksheets("Sheet1").Range("A:A")
    Set Rng2 = Workbooks("1.[COLOR="Red"]xlsm[/COLOR]").Worksheets("Sheet1").Range("A2")
    Set Rng3 = Workbooks("1.[COLOR="red"]xlsm[/COLOR]").Worksheets("Sheet1").Range("A6")

    Lookup = Workbooks("1.[COLOR="Red"]xlsm[/COLOR]").Worksheets("Sheet1").Range("A1").Value

    Set rSearch = Rng1.Find(What:=Lookup, After:=Range("A1"), _
                            LookIn:=xlValues, LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)

    If rSearch Is Nothing Then
        
        MsgBox ("No Match Found")
        Workbooks("2.xlsx").Close
        Application.ScreenUpdating = True
        Exit Sub
    
    End If

    Rng2.Value = rSearch.Offset(, 1).Value
    Rng3.Value = rSearch.Offset(, 2).Value

    Workbooks("2.xlsx").Close

    Application.ScreenUpdating = True

End Sub
 

Excelnoobisme

Board Regular
Joined
Nov 19, 2010
Messages
128
Sub Testing()

dim wb1, wb2 as workbook
set wb1 = activeworkbook
Workbooks.Open Filename:="C:\2.xlsx"

set wb2 = activeworkbook

Dim ff As Range
Set ff = wb2.Sheets("sheets1").Columns("A").Find(what:=wb1.Sheets("sheet1").Range("A1").Value, LookIn:=xlValues, lookat:=xlWhole)

If ff Is Nothing Then
MsgBox "Not found"
Else

wb2.sheets("sheet1").Range(ff.Address).Offset(0, 1).copy
wb1.sheets("sheet1").range("a2").PasteSpecial Paste:=xlPasteValues

wb2.sheets("sheet1").Range(ff.Address).Offset(0, 2).copy
wb1.sheets("sheet1").range("a6").PasteSpecial Paste:=xlPasteValues


End If

ActiveWorkbook.Save
ActiveWindow.Close

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,123,336
Messages
5,601,023
Members
414,421
Latest member
tonybear1994

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top