Match and retrieve values from another workbook

[Cortex1000]

Hello Everyone,

I am struggling creating a VBA code dealing with data retrieval from another opened workbook. I have a main workbook on which the data is manually being fed in from a secondary workbook. At the minute this is a copy and paste job. I am looking to automate this by pressing a button to call a VBA that will sit in Personal.XLSB. I am quite new to VBA and I am learning hitting my head to all of these problems.

I use column E (test5) to match the data between the workbooks.

Unfortunately I am not able to use XL2BB. I hope you can retrieve the table.

Main Workbook (where the info needs to go in)

test1	test2	test3	test4	test5	test6	test7	test8	test9	test10	test11	test12
			info0	R2000R22102312345	info10	info20	info30	info40	info50
				R2000R22102312332
			info1	R2000R22102312342	info11	info21	info31	info41	info51
				R2000R22102312312
				R2000R22102312324
			info2	R2000R22102312350	info12	info22	info32	info42	info52
				R2000R22102312330

Secondary Workbook (where the info is)

test1	test2	test3	test4	test5	test6	test7	test8	test9	test10	test11	test12
			info0	R2000R22102312345	info10	info20	info30	info40	info50
			info1	R2000R22102312342	info11	info21	info31	info41	info51
			info2	R2000R22102312350	info12	info22	info32	info42	info52
			info3	R2000R22102312332	info13	info23	info33	info43	info53
			info4	R2000R22102312312	info14	info24	info34	info44	info54
			info5	R2000R22102312324	info15	info25	info35	info45	info55
			info6	R2000R22102312330	info16	info26	info36	info46	info56

This code works on small scale but the problem is the Main Workbook has thousands of rows that are already been filled in and it just crashes excel.
The code I have works by opening it automatically from desktop which I don't really need now as secondary workbook will be always open when transferring the data.

Sub WithButton()
Dim KeyCells As Range
Dim Sheet1, Sheet2 As Worksheet
Dim CellChanged As Integer
Dim Path, File As String
Dim LastRow, LastData As Long
Dim Found As Boolean

Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic

On Error GoTo Handle

            Set Sheet1 = ThisWorkbook.Worksheets("record") 'Edit Sheet File1

            If Sheet1.Range("Z1").Value = "" Then
    Sheet1.Range("Z1").Value = 0
    CellChanged = Sheet1.Cells(Rows.Count, "E").End(xlUp).Row
End If

If Sheet1.Cells(Rows.Count, "E").End(xlUp).Row > Sheet1.Range("Z1").Value Then
    Path = "C:\Users\user\Desktop\secondwb.xls" 'Edit Path File2
    File = Right$(Path, Len(Path) - InStrRev(Path, "\"))

    CellChanged = Sheet1.Range("Z1").Value + 1
    Workbooks.Open (Path)
            Set Sheet2 = Workbooks(File).Worksheets("data") 'Edit Sheet of File2

               LastRow = Sheet2.Cells(Rows.Count, "E").End(xlUp).Row
    LastData = Sheet1.Cells(Rows.Count, "E").End(xlUp).Row

    For I = 1 To LastRow
        If Sheet1.Range("E" & CellChanged).Value = Sheet2.Range("E" & I) Then
            Sheet1.Range("D" & CellChanged).Value = Sheet2.Range("D" & I).Value
            Sheet1.Range("F" & CellChanged).Value = Sheet2.Range("F" & I).Value
            Sheet1.Range("G" & CellChanged).Value = Sheet2.Range("G" & I).Value
            Sheet1.Range("H" & CellChanged).Value = Sheet2.Range("H" & I).Value
            Sheet1.Range("I" & CellChanged).Value = Sheet2.Range("I" & I).Value
            Sheet1.Range("J" & CellChanged).Value = Sheet2.Range("J" & I).Value
            Found = True
        End If
        If Found = True Or I = LastRow Then
            If CellChanged = LastData Then
                Exit For
            End If
        If Found = True Then
            Found = False
            CellChanged = CellChanged + 1
        Else
            CellChanged = CellChanged + 1
            End If
            I = 0
        End If
    Next I
    Workbooks(File).Close savechanges:=False
                Sheet1.Range("Z1").Value = CellChanged
End If
Exit Sub
Handle:
    MsgBox ("Error")
End Sub

Now the question is.. Is anybody whiling to have a look into this and help me with a shorter option that works with high amount of data? Both workbooks will be opened when retrieving data so I think it wont need a path but I am happy to understand your perspective.

Thank you,
David

 

[dave3009]

Hi David

You can make a few space saving changes, resizing contiguous ranges could be quicker then writing line by line.
Change the codename of Sheet1 to sh_Record in the properties panel
Create a reference for the destination workbook.

I haven't tested this, but it should give you a few ideas

Option Explicit

Sub WithButton()
Dim KeyCells As Range
'Dim Sheet1, Sheet2 As Worksheet ' you can remove the first sheet ref here, see below
Dim sh_Data As Worksheet ' new variable for sheet2
Dim CellChanged As Integer
Dim LastRow, LastData As Long
Dim Found As Boolean
Dim wb2 As Workbook ' added a variable for the workbook you open

Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic

On Error GoTo Handle

' /*
' rename ThisWorkbook.Worksheets("record") as sh_Record
' you can remove everything from /* to */
'Set Sheet1 = ThisWorkbook.Worksheets("record") 'Edit Sheet File1
' */


With sh_Record
    If .Range("Z1").Value = "" Then
        .Range("Z1").Value = 0
        CellChanged = .Cells(Rows.Count, "E").End(xlUp).Row
    End If
    
    If .Cells(Rows.Count, "E").End(xlUp).Row > .Range("Z1").Value Then
        Set wb2 = Workbooks.Open("C:\Users\user\Desktop\secondwb.xls")
        Set sh_Data = wb2.Worksheets("data") 'Edit Sheet of File2
        
        CellChanged = .Range("Z1").Value + 1
        LastRow = sh_Data.Cells(Rows.Count, "E").End(xlUp).Row
        LastData = .Cells(Rows.Count, "E").End(xlUp).Row
    
        For I = 1 To LastRow
            If .Range("E" & CellChanged).Value = sh_Data.Range("E" & I) Then
                .Range("D" & CellChanged).Value = sh_Data.Range("D" & I).Value
                .Range("F" & CellChanged).Resize(, 5).Value = sh_Data.Range("F" & I).Resize(, 5).Value
                Found = True
            End If
            If Found = True Or I = LastRow Then
                If CellChanged = LastData Then
                    Exit For
                End If
            If Found = True Then
                Found = False
                CellChanged = CellChanged + 1
            Else
                CellChanged = CellChanged + 1
                End If
                I = 0
            End If
        Next I
        wb2.Close False
        .Range("Z1").Value = CellChanged
    End If
End With
Exit Sub
Handle:
    MsgBox ("Error")
End Sub

 

[Cortex1000]

Hello Dave,

Thanks very much for your assistance. I believe I got myself more lost than I was in the first instance. I will keep try to make it work somehow. Thanks again for you help.

Kind Regards
David

 

[Cortex1000]

Hello Everyone,

Me again . I have been working on this for few hours and I still can't make it work. Is someone willing to have a look into this?
Does anyone know a easier way to pull the information with a code similar to this?

Appreciate your interest.