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
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Make sure that both workbooks are open. Place this macro in a standard module in Workbook1 and run it from there. Change the sheet names (in red) and the workbook name (in blue) to suit your needs.
Code:
Sub GetBusNUms()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
    Set srcWS = ThisWorkbook.Sheets("[COLOR="#FF0000"]Sheet1[/COLOR]")
    Set desWS = Workbooks("[COLOR="#0000FF"]Workbook2.xlsx[/COLOR]").Sheets("[COLOR="#FF0000"]Sheet1[/COLOR]")
    For Each bus In desWS.Range("A2", desWS.Range("A" & desWS.Rows.Count).End(xlUp))
        Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(bus, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            bus.Offset(0, 8) = fnd.Offset(0, -1)
        End If
    Next bus
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thanks mumps ,
Code Worked Perfect , Only Issue i have is On workbook 2 Bus NUmbers start with W### and in Workbook1 Bus Number are Just ### .
Any way to Ignore the W .

Make sure that both workbooks are open. Place this macro in a standard module in Workbook1 and run it from there. Change the sheet names (in red) and the workbook name (in blue) to suit your needs.
Code:
Sub GetBusNUms()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
    Set srcWS = ThisWorkbook.Sheets("[COLOR=#FF0000]Sheet1[/COLOR]")
    Set desWS = Workbooks("[COLOR=#0000FF]Workbook2.xlsx[/COLOR]").Sheets("[COLOR=#FF0000]Sheet1[/COLOR]")
    For Each bus In desWS.Range("A2", desWS.Range("A" & desWS.Rows.Count).End(xlUp))
        Set fnd = srcWS.Range("B:B,D:D,F:F,H:H").Find(bus, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            bus.Offset(0, 8) = fnd.Offset(0, -1)
        End If
    Next bus
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try:
Code:
Sub GetBusNUms()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set desWS = Workbooks("Workbook2.xlsx").Sheets("Sheet1")
    For Each bus In desWS.Range("A2", desWS.Range("A" & 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 Then
            bus.Offset(0, 8) = fnd.Offset(0, -1)
        End If
    Next bus
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thanks alot Buddy , You are Supergenuis and Sorry for Late Reply i was on Vacation .

Try:
Code:
Sub GetBusNUms()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set desWS = Workbooks("Workbook2.xlsx").Sheets("Sheet1")
    For Each bus In desWS.Range("A2", desWS.Range("A" & 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 Then
            bus.Offset(0, 8) = fnd.Offset(0, -1)
        End If
    Next bus
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You are very welcome. :)
 
Upvote 0
Hey Mumps
This code is giving me unknown values for Blank Cells any suggestion how to include Skiping blank cells in code , If Not IsEmpty(cell) Then , but no luck .
Thanks
Thanks alot Buddy , You are Supergenuis and Sorry for Late Reply i was on Vacation .
 
Upvote 0
Try:
Code:
Sub GetBusNums()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set desWS = Workbooks("Workbook2.xlsx").Sheets("Sheet1")
    For Each bus In desWS.Range("A2", desWS.Range("A" & 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, 8) = fnd.Offset(0, -1)
            End If
        End If
    Next bus
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thanks
Try:
Code:
Sub GetBusNums()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, bus As Range, fnd As Range
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set desWS = Workbooks("Workbook2.xlsx").Sheets("Sheet1")
    For Each bus In desWS.Range("A2", desWS.Range("A" & 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, 8) = fnd.Offset(0, -1)
            End If
        End If
    Next bus
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,526
Messages
6,114,136
Members
448,551
Latest member
Sienna de Souza

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