Extract Data from Another workbook , Match data and Paste

Jeet_Dhillon

New Member
Joined
Jul 13, 2019
Messages
19
Hello Guys ,
I am Beginner in Excel VBA .
I have 2 Workbooks with Bus Numbers and Locations . Workbook 1 Contains Bus Locations in A ,C,E,G and Bus Numbers in Column B, D,F,H. Workbook 2 Contains some Random Bus Numbers In Column A and Missing Bus Locations in Column I . Workbook 1 gets Updated Bus Locations Everyday . I am trying to Extract Bus Locations from Workbook 1 and Paste in WorkBook 2 Column I .
Any Suggestions .
Thanks
 
Hi Mumps
I Tried your code as a Base for other Sheet ,but this time code is taking ages to come up with Result .
Any idea what i am doing Wrong .
Thanks

Private Sub GetBus_Click()
Application.ScreenUpdating = False
Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
On Error Resume Next
FileExists = False
For Each book In Workbooks
If book.Name = "Master_Garage Parking Control.xlsm" Then
FileExists = True
End If
Next book
If FileExists = False Then
dum = MsgBox("Please Open Parking Control in Background", vbExclamation, _
"Parking Control Not Open")
End If
Set srcWS = Workbooks("Master_Garage Parking Control.xlsm").Sheets("Bus Number Input")
Set desWS = ThisWorkbook.Sheets("Forepersons Report")
For Each bus In desWS.Range("B19:B64", desWS.Range("B" & desWS.Rows.Count).End(xlUp))
Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(Mid(bus, 2, 9999), LookIn:=xlValues, lookat:=xlWhole)
If Not fnd Is Nothing And Len(bus) > 0 Then
bus.Offset(0, 17) = fnd.Offset(0, -1)
End If
Next bus
For Each bus In desWS.Range("W3:W33", desWS.Range("W" & desWS.Rows.Count).End(xlUp))
Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(Mid(bus, 2, 9999), LookIn:=xlValues, lookat:=xlWhole)
If Not fnd Is Nothing And Len(bus) > 0 Then
bus.Offset(0, 5) = fnd.Offset(0, -1)
End If
Next bus
Application.ScreenUpdating = True
End Sub
 
Upvote 0

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
See if this version helps. If not, it would be easier to help if you could upload a copy of your files to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file file that you can post here. If the workbooks contain confidential information, you could replace it with generic data.
Code:
Private Sub GetBus_Click()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
    If MsgBox("Is 'Master_Garage Parking Control.xlsm' open?", vbYesNo) = vbYes Then
        Set srcWS = Workbooks("Master_Garage Parking Control.xlsm").Sheets("Bus Number Input")
        Set desWS = ThisWorkbook.Sheets("Forepersons Report")
        For Each bus In desWS.Range("B19:B64", desWS.Range("B" & desWS.Rows.Count).End(xlUp))
            If bus <> "" Then
                Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(Mid(bus, 2, 9999), LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    bus.Offset(0, 17) = fnd.Offset(0, -1)
                End If
            End If
        Next bus
        For Each bus In desWS.Range("W3:W33", desWS.Range("W" & desWS.Rows.Count).End(xlUp))
            If bus <> "" Then
                Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(Mid(bus, 2, 9999), LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing And Len(bus) > 0 Then
                    bus.Offset(0, 5) = fnd.Offset(0, -1)
                End If
            End If
        Next bus
    Else
        MsgBox ("'Master_Garage Parking Control.xlsm' must be open." & Chr(10) & "Please open the file and try again.")
    End If
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thanks for Reply ,
I tried this code Still the Worksheet is taking same amount of time 10 Sec .
Please See the Links for 2 Files i am Trying to Sync
https://drive.google.com/file/d/16fP2kGol0NadByn3e1j23IGPvoo4bu5n/view?usp=drivesdk

https://drive.google.com/file/d/1c4M9Ez98i4MXl3N39-gwWK5pEz2XTN-C/view?usp=drivesdk



See if this version helps. If not, it would be easier to help if you could upload a copy of your files to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file file that you can post here. If the workbooks contain confidential information, you could replace it with generic data.
Code:
Private Sub GetBus_Click()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
    If MsgBox("Is 'Master_Garage Parking Control.xlsm' open?", vbYesNo) = vbYes Then
        Set srcWS = Workbooks("Master_Garage Parking Control.xlsm").Sheets("Bus Number Input")
        Set desWS = ThisWorkbook.Sheets("Forepersons Report")
        For Each bus In desWS.Range("B19:B64", desWS.Range("B" & desWS.Rows.Count).End(xlUp))
            If bus <> "" Then
                Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(Mid(bus, 2, 9999), LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    bus.Offset(0, 17) = fnd.Offset(0, -1)
                End If
            End If
        Next bus
        For Each bus In desWS.Range("W3:W33", desWS.Range("W" & desWS.Rows.Count).End(xlUp))
            If bus <> "" Then
                Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(Mid(bus, 2, 9999), LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing And Len(bus) > 0 Then
                    bus.Offset(0, 5) = fnd.Offset(0, -1)
                End If
            End If
        Next bus
    Else
        MsgBox ("'Master_Garage Parking Control.xlsm' must be open." & Chr(10) & "Please open the file and try again.")
    End If
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try:
Code:
Private Sub GetBus_Click()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
    If MsgBox("Is 'Master_Garage Parking Control.xlsm' open?", vbYesNo) = vbYes Then
        Set srcWS = Workbooks("Master_Garage Parking Control.xlsm").Sheets("BUS NUMBER INPUT")
        Set desWS = ThisWorkbook.Sheets("Forepersons Report")
        For Each bus In desWS.Range("B19:B64", desWS.Range("B" & desWS.Rows.Count).End(xlUp))
            If bus <> "" Then
                Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(Mid(bus, 2, 9999), LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    bus.Offset(0, 17) = fnd.Offset(0, -1)
                End If
            End If
        Next bus
        For Each bus In desWS.Range("W3:W33", desWS.Range("W" & desWS.Rows.Count).End(xlUp))
            If bus <> "" Then
                Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(Mid(bus, 2, 9999), LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing And Len(bus) > 0 Then
                    bus.Offset(0, 5) = fnd.Offset(0, -1)
                End If
            End If
        Next bus
    Else
        MsgBox ("'Master_Garage Parking Control.xlsm' must be open." & Chr(10) & "Please open the file and try again.")
    End If
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub
To keep responses less cluttered, please click the "Reply" button instead of the "Reply with Quote" button.
 
Upvote 0
This Code Worked like a Charm , Day and Night Difference .
Thanks a lot .
For my Curiosity ,is it because of disabling other events ?.
 
Upvote 0
You are very welcome. :) Yes, that is correct. You have many "event" macros which were being triggered unnecessarily which of course took more time.
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,237
Members
448,555
Latest member
RobertJones1986

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
Back
Top