A Way to List Multiple Services Before Code Runs

[Legacy 436357]

Hello,

I have this code that will update the appropriate vehicle when the selected service is entered.

How it works now is one service is entered at a time. On most occasions it would be better to be able to select multiple services.

Does anyone have ideas on how to perhaps have the list of services and select the Date, O/D, Vehicle, and type of service?

Thank you I appreciate any help or advice.

Excel Workbook
	A	B	C	D
2	Date of Service	Vehicle	Odometer	Work Performed and Service Schedule
3	07/29/2017	2014 Dodge Dart	50100	Changed engine oil and filter
4	07/29/2017	2014 Dodge Dart	50100	Checked battery terminals and cables for corrosion
5	07/29/2017	2014 Dodge Dart	50100	Checked brake fluid
Service Entries

#VALUE!

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim SheetName As String         ' Vehicle name
Dim sh As Worksheet             ' Vehicle worksheet
Dim DateofService As Date       ' Date of service
Dim Odometer As Long            ' Odometer reading
Dim TypeService As String       ' Type of service
Dim rng As Range                ' Range for find command
Dim LCol As Long                ' Last column of found service

If Target.Cells.Count > 1 Then Exit Sub

If Intersect(Target, Range("Table_Service[Work Performed and Service Schedule]")) Is Nothing Then Exit Sub

SheetName = Cells(Target.Row, "B")
DateofService = Cells(Target.Row, "A")
Odometer = Cells(Target.Row, "C")
TypeService = Cells(Target.Row, "D")

Set sh = Sheets(SheetName)

' Look for type of service on sheet
Set rng = sh.Range("A3:A500").Find(TypeService, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
    ' If service isn't found, exit the program
    MsgBox TypeService & " was not found for vehicle, " & SheetName
    Exit Sub
Else
    ' Shift history over by copying everything two columns to left and then moving existing data over
    LCol = sh.Cells(rng.Row, Columns.Count).End(xlToLeft).Column
    
    If LCol = 4 Then GoTo PutCells
    ' if the first entry, just put the cells
    
    If LCol = 6 Then
        ' If the second entyr copy the cells over
        sh.Cells(rng.Row, "G") = sh.Cells(rng.Row, "E")
        sh.Cells(rng.Row, "H") = sh.Cells(rng.Row, "F")
    Else
        ' For later entries move the range and copy the cells
        sh.Range(sh.Cells(rng.Row, "G"), sh.Cells(rng.Row, LCol)).Copy sh.Cells(rng.Row, "I")
        sh.Cells(rng.Row, "G") = sh.Cells(rng.Row, "E")
        sh.Cells(rng.Row, "H") = sh.Cells(rng.Row, "F")
    End If
    
PutCells:
    ' Put new values in the appropriate place
    sh.Cells(rng.Row, "E") = DateofService
    sh.Cells(rng.Row, "F") = Odometer
End If

End Sub

 

[Legacy 436357]

bump please