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

 

[mumps]

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.

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

 

[Jeet_Dhillon]

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.

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

 

[mumps]

Try:

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

 

[Jeet_Dhillon]

Thanks alot Buddy , You are Supergenuis and Sorry for Late Reply i was on Vacation .

Try:

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

 

[mumps]

You are very welcome.

 

[Jeet_Dhillon]

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 .

 

[mumps]

Try:

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

 

[Jeet_Dhillon]

Thanks

Try:

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

 

[mumps]

My plessure..