Option ExplicitDim aWeight() As Integer
Dim aAutoData() As Variant
Dim Row As Integer
Sub LoadArrays()
Dim r As Integer
ReDim aTransliterate(35, 1)
ReDim aWeight(16)
ReDim aAutoData(1, 21)
Application.ScreenUpdating = False
Sheets("data").visible = True
'Load Arrays
Sheets("data").Select
Range("A2").Select
For r = 0 To UBound(aWeight)
aWeight(r) = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Next
Range("D2").Select
For r = 0 To UBound(aAutoData, 2)
aAutoData(0, r) = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Next
Sheets("VIN List").Select
Sheets("data").visible = False
Application.ScreenUpdating = True
End Sub
Sub LoadFile()
Dim FileName As String
Dim FileType As String
Application.ScreenUpdating = False
'get name and path of file.
FileName = Application.GetOpenFilename
If FileName = "False" Then
Application.ScreenUpdating = True
Exit Sub
End If
If UCase(Right(FileName, 4)) <> ".TXT" Then
Application.ScreenUpdating = True
MsgBox "VIN file must be a text file"
Exit Sub
End If
'clear all old VINs
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Clear
'Load new VINs
Range("A2").Select
ReadFile (FileName)
Application.ScreenUpdating = True
Range("A2").Select
MsgBox "VINs Loaded Successfully."
End Sub
Sub ReadFile(FilePath As String) 'FilePath must containt the full file path and name
'Must use Tools > References > Microsoft Scripting Runtime
Dim sText As String
Dim oFSO As New FileSystemObject
Dim oFS As Object
Set oFS = oFSO.OpenTextFile(FilePath)
Range("A2").Select
Do Until oFS.AtEndOfStream
ActiveCell.Value = oFS.ReadLine
ActiveCell.Offset(1, 0).Select
Loop
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Columns.AutoFit
Selection.NumberFormat = "@"
Range("A2").Select
End Sub
Sub VINValidator()
'calls the ChkVIN function to validate the VIN
Range("A2").Select
Do While ActiveCell.Value <> ""
ActiveCell.Offset(0, 1).Value = ChkVIN(ActiveCell.Value)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Function ChkVIN(VIN As String) As String
'Returns "Yes" if VIN is valid and "No" if its not valid
Dim aVIN(16) As String
Dim aValue(16) As Integer
Dim aProduct(16) As Integer
Dim x As Integer
Dim ChkDigit As String
Dim ProdSum As Integer
ProdSum = 0
'transliterate VIN digits, multiply values by weith, place results in aProduct array, and sum all products
For x = 0 To UBound(aVIN)
aVIN(x) = UCase(Mid(VIN, x + 1, 1))
If x = 8 Then
'the check digit must be transliterated to a 0.
aValue(x) = 0
Else
aValue(x) = Transliterate(aVIN(x))
End If
aProduct(x) = aWeight(x) * aValue(x)
ProdSum = ProdSum + aProduct(x)
If aValue(x) = -1 Or aProduct(x) = -1 Then
ChkVIN = "No"
Exit Function
End If
Next x
ChkDigit = ProdSum Mod 11
If ChkDigit = 10 Then
ChkDigit = "X"
End If
'aVIN(8) contains the supplied check digit while ChkDigit contains the calculated check digit
If ChkDigit <> aVIN(8) Then
ChkVIN = "No"
Exit Function
Else
ChkVIN = "Yes"
End If
'clear out local variables and arrays
For x = 0 To UBound(aVIN)
aVIN(x) = Empty
Next
For x = 0 To UBound(aValue)
aValue(x) = Empty
Next
For x = 0 To UBound(aProduct)
aProduct(x) = Empty
Next
x = Empty
ChkDigit = Empty
ProdSum = Empty
End Function
Function Transliterate(Value As String) As Integer
'Transliterate will return a -1 if Value = I, O, Q, or some other invalid character
Select Case UCase(Value)
Case "A"
Transliterate = 1
Exit Function
Case "B"
Transliterate = 2
Exit Function
Case "C"
Transliterate = 3
Exit Function
Case "D"
Transliterate = 4
Exit Function
Case "E"
Transliterate = 5
Exit Function
Case "F"
Transliterate = 6
Exit Function
Case "G"
Transliterate = 7
Exit Function
Case "H"
Transliterate = 8
Exit Function
Case "I"
Transliterate = -1
Exit Function
Case "J"
Transliterate = 1
Exit Function
Case "K"
Transliterate = 2
Exit Function
Case "L"
Transliterate = 3
Exit Function
Case "M"
Transliterate = 4
Exit Function
Case "N"
Transliterate = 5
Exit Function
Case "O"
Transliterate = -1
Exit Function
Case "P"
Transliterate = 7
Exit Function
Case "Q"
Transliterate = -1
Exit Function
Case "R"
Transliterate = 9
Exit Function
Case "S"
Transliterate = 2
Exit Function
Case "T"
Transliterate = 3
Exit Function
Case "U"
Transliterate = 4
Exit Function
Case "V"
Transliterate = 5
Exit Function
Case "W"
Transliterate = 6
Exit Function
Case "X"
Transliterate = 7
Exit Function
Case "Y"
Transliterate = 8
Exit Function
Case "Z"
Transliterate = 9
Exit Function
Case "1"
Transliterate = 1
Exit Function
Case "2"
Transliterate = 2
Exit Function
Case "3"
Transliterate = 3
Exit Function
Case "4"
Transliterate = 4
Exit Function
Case "5"
Transliterate = 5
Exit Function
Case "6"
Transliterate = 6
Exit Function
Case "7"
Transliterate = 7
Exit Function
Case "8"
Transliterate = 8
Exit Function
Case "9"
Transliterate = 9
Exit Function
Case "0"
Transliterate = 0
Exit Function
Case Else
Transliterate = -1
Exit Function
End Select
End Function
Sub VINDecoder()
'Calls the LookupVINOnline and FetchData subroutines to decode the VIN
Dim sVIN As String
Dim sValid As String
Sheets("vin list").Select
Range("A2").Select
Do While ActiveCell.Value <> Empty
Row = ActiveCell.Row
sVIN = ActiveCell.Value
sValid = ActiveCell.Offset(0, 1).Value
'Only lookup VINs that are valid
If sValid = "" Then
ActiveCell.Offset(0, 1).Value = ChkVIN(ActiveCell.Value)
sValid = ActiveCell.Offset(0, 1).Value
End If
If sValid = "Yes" Then
Application.ScreenUpdating = False
LookupVINOnline sVIN
FetchData
Application.ScreenUpdating = True
End If
ActiveCell.Offset(1, 0).Select
Loop
MsgBox "VINs decoded successfully."
End Sub
Sub LookupVINOnline(VIN As String)
'looks up the VIN online and copies the data to the "VIN Data" sheet
Dim sURL As String
sURL = "URL;http://www.decodethis.com/Default.aspx?tabid=65&vin=" & VIN
Sheets("vin data").visible = True
Sheets("vin data").Select
Range("A2").Select
With Selection.QueryTable
.Connection = sURL
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = """TableRight"""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Sheets("vin data").visible = False
End Sub
Sub FetchData()
'Fetches the colletcted data from the "VIN Data" sheet and pastes it in the correct column in the "VIN List" sheet
'This function uses a dynamic array (aAutoData) to transfer the values from the "VIN Data" sheet to the "VIN List" sheet
Dim rFind As Range
Dim x As Integer
Dim Count As Integer
Dim OrigSize As Integer
Dim NewSize As Integer
'The aAutoData array contains a list of the data that will be searched for in the VIN Data sheet
'the data for this array is contained in the "Data" sheet which is a hidden sheet
OrigSize = UBound(aAutoData, 2)
Sheets("vin data").visible = True
Sheets("vin data").Select
Range("A2").Select
For x = 0 To UBound(aAutoData, 2)
Set rFind = Cells.find(What:=aAutoData(0, x), LookAt:=xlWhole, SearchOrder:=xlByColumns)
'if serached term is not found then assume the web query did not find any data for the VIN
If rFind Is Nothing Then
Sheets("VIN List").Select
Cells(Row, 3).Value = "No data found."
Exit Sub
End If
rFind.Select
If ActiveCell.Offset(0, 1).Value = "" Then
aAutoData(1, x) = "No data"
Else
aAutoData(1, x) = ActiveCell.Offset(0, 1).Value
End If
Next
'The web query may return multiple entries for the "Transmission". The following code identifies
'how many entries there are for the transmission and adjusts the aAutoData to be able to hold all the data
ActiveCell.Offset(1, 0).Select
Do While ActiveCell.Value = ""
Count = Count + 1
ActiveCell.Offset(1, 0).Select
Loop
If Count <> 0 Then
NewSize = OrigSize + Count
ReDim Preserve aAutoData(1, NewSize)
ActiveCell.Offset(-Count, 0).Select
For x = 1 To Count
aAutoData(1, OrigSize + x) = ActiveCell.Offset(0, 1).Value
ActiveCell.Offset(1, 0).Select
Next
End If
'Place the data from the aAutoData array into the correct columns in the "VIN List" sheet
Sheets("vin data").visible = False
Sheets("VIN List").Select
Cells(Row, 3).Select
For x = 0 To UBound(aAutoData, 2)
Selection.NumberFormat = "@" 'turn cell format = text
ActiveCell.Value = aAutoData(1, x)
Selection.EntireColumn.AutoFit
ActiveCell.Offset(0, 1).Select
Next
Cells(Row, 1).Select
VINList.Select
Sheets("vin data").visible = False
'Clear data
rFind = Empty
ReDim Preserve aAutoData(1, 21)
For x = 0 To UBound(aAutoData, 2)
aAutoData(1, x) = Empty
Next
x = 0
Count = 0
OrigSize = Empty
NewSize = Empty
End Sub
