Extract Data from Another workbook , Match data and Paste

[Jeet_Dhillon]

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

 

[Jeet_Dhillon]

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

 

[mumps]

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.

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

 

[Jeet_Dhillon]

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.

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

 

[mumps]

Try:

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.

 

[Jeet_Dhillon]

This Code Worked like a Charm , Day and Night Difference .
Thanks a lot .
For my Curiosity ,is it because of disabling other events ?.

 

[mumps]

You are very welcome. Yes, that is correct. You have many "event" macros which were being triggered unnecessarily which of course took more time.