Soldato
- Joined
- 8 Sep 2003
- Posts
- 23,180
- Location
- Was 150 yds from OCUK - now 0.5 mile; they moved
Hey guys I have written a program to validate a spredsheet which my company receive form various companys for orders...this automates the data check, and the save and rename into a .csv file and as adds it as an attachment to a outlook email ready for transferring to our AS/400 system
Would you say this VB code is any good? professionally written?
Would you say this VB code is any good? professionally written?
' **************************************************************
' * *
' * Subroutine to validate the data in a new order spreadsheet *
' * *
' * Written by: Lee Bryan *
' * [email protected] *
' * Written on: 18th July 2007 *
' * Last Update: 1st August 2007 *
' * *
' **************************************************************
Option Explicit
Sub validate()
' **********************************
' Declare and initialise variables
' **********************************
Dim counter As Integer
Dim count As Integer
Dim intRows As Integer
Dim intColumns As Integer
Dim columnChar As Integer
Dim w As Workbook
Dim s As Worksheet
Dim eMess As String
Dim myDate As String
Dim orderDate As String
Dim telephone As String
Dim postcode As String
Set w = ActiveWorkbook
Set s = w.ActiveSheet
eMess = ""
' **************************************
' Set up the bounds of the valid cells
' **************************************
s.Unprotect
intRows = s.UsedRange.Rows.count
s.Range("Y1D500").Delete
For count = intRows To 2 Step -1
If (IsEmpty(s.Range("G" & count).Value) And IsEmpty(s.Range("H" & count).Value) And IsEmpty(s.Range("I" & count).Value)) Then
s.Rows(count).EntireRow.Delete
End If
Next
Columns("A:Y").Select
Selection.EntireColumn.Hidden = False
' **********************************
' Format the columns as 'text' so
' we do not loose leading zeros
' **********************************
Selection.NumberFormat = "@"
w.Save
intRows = s.UsedRange.Rows.count
' ************************************
' Get the order date for replacement
' ************************************
If (intRows = 2) Then
orderDate = Application.InputBox(prompt:="There is 1 order on the sheet." & vbCrLf & vbCrLf & "Please enter the day and month that the " & vbCrLf & "sheet was sent e.g. 0206", Type:=2)
myDate = Year(Now) & Right(orderDate, 2) & Left(orderDate, 2)
Else
orderDate = Application.InputBox(prompt:="There are " & (intRows - 1) & " orders on this sheet." & vbCrLf & vbCrLf & "Please enter the day and month that the " & vbCrLf & "sheet was sent e.g. 0206", Type:=2)
myDate = Year(Now) & Right(orderDate, 2) & Left(orderDate, 2)
End If
' **************************
' Set up the column labels
' **************************
s.Range("a1").Value = "record type"
s.Range("b1").Value = "type"
s.Range("c1").Value = "consignment NO"
s.Range("d1").Value = "Order Number"
s.Range("e1").Value = "order number 2"
s.Range("f1").Value = "account no"
s.Range("g1").Value = "no of items"
s.Range("h1").Value = "weight"
s.Range("i1").Value = "address line 1"
s.Range("j1").Value = "address line 2"
s.Range("k1").Value = "address line 3"
s.Range("l1").Value = "address line 4"
s.Range("m1").Value = "post code"
s.Range("n1").Value = "title of customer"
s.Range("o1").Value = "forename of customer"
s.Range("p1").Value = "initials"
s.Range("q1").Value = "surname"
s.Range("r1").Value = "telephone number of customer"
s.Range("s1").Value = "2nd tele number"
s.Range("t1").Value = "3rd tele no"
s.Range("u1").Value = "email address"
s.Range("v1").Value = "order date"
s.Range("w1").Value = "delivery instructions"
s.Range("x1").Value = "product description"
' **********************
' For each row in turn
' **********************
For counter = 2 To intRows
' ******************************************
' Replace every comma ',' with a space ' '
' ******************************************
For columnChar = 65 To 88
s.Range(Chr(columnChar) & counter).Value = REP(s.Range(Chr(columnChar) & counter).Value, ",", " ")
Next columnChar
' **************************************************
' Replace every forward slash '/' with a space ' '
' **************************************************
For columnChar = 65 To 88
s.Range(Chr(columnChar) & counter).Value = REP(s.Range(Chr(columnChar) & counter).Value, "/", " ")
Next columnChar
' ***********************************************
' Replace every underscore '_' with a space ' '
' ***********************************************
For columnChar = 65 To 88
s.Range(Chr(columnChar) & counter).Value = REP(s.Range(Chr(columnChar) & counter).Value, "_", " ")
Next columnChar
' ****************************************
' Check all mandatory fields are present
' ****************************************
'Row D
If (IsEmpty(s.Range("d" & counter).Value)) Then
eMess = eMess & "No data in mandatory cell D" & counter & vbCrLf
End If
'Row F
If (IsEmpty(s.Range("f" & counter).Value)) Then
eMess = eMess & "No data in mandatory cell F" & counter & vbCrLf
End If
'Row I
If (IsEmpty(s.Range("i" & counter).Value)) Then
If Not (IsEmpty(s.Range("j" & counter).Value)) Then
s.Range("i" & counter).Value = s.Range("j" & counter).Value
s.Range("j" & counter).Value = s.Range("k" & counter).Value
s.Range("k" & counter).Value = s.Range("l" & counter).Value
s.Range("l" & counter).Value = ""
Else
eMess = eMess & "No data in mandatory cell I" & counter & vbCrLf
End If
End If
'Row M
If (IsEmpty(s.Range("m" & counter).Value)) Then
eMess = eMess & "No data in mandatory cell M" & counter & vbCrLf
End If
'Row Q
If (IsEmpty(s.Range("q" & counter).Value)) Then
If Not (IsEmpty(s.Range("n" & counter).Value)) Then
s.Range("q" & counter).Value = s.Range("n" & counter).Value
s.Range("n" & counter).Value = ""
Else
eMess = eMess & "No data in mandatory cell Q" & counter & vbCrLf
End If
End If
'Row R
If (IsEmpty(s.Range("r" & counter).Value)) Then
eMess = eMess & "No data in mandatory cell R" & counter & vbCrLf
End If
' *****************************
' Validate individual columns
' *****************************
' Column 'A' should contain "300"
s.Range("a" & counter).Value = "300"
' Column 'B' should contain "01" or "02" or "11" or "12"
If (Val(s.Range("b" & counter).Value) = 1) Or (Val(s.Range("b" & counter).Value) = 2) Or (Val(s.Range("b" & counter).Value) = 11) Or (Val(s.Range("b" & counter).Value) = 12) Then
If (Val(s.Range("b" & counter).Value) = 1) Then
s.Range("b" & counter).Value = "01"
End If
If (Val(s.Range("b" & counter).Value) = 2) Then
s.Range("b" & counter).Value = "02"
End If
Else
eMess = eMess & "Invalid Order Type in cell B" & counter & ", "
End If
' Column 'C' should contain "00000000"
s.Range("c" & counter).Value = "00000000"
' Column 'D' should be a maximum of 15 chars
s.Range("d" & counter).Value = Left(s.Range("d" & counter).Value, 15)
' Column 'E' should be a maximum of 15 chars
s.Range("e" & counter).Value = Left(s.Range("e" & counter).Value, 15)
' Column 'F' should be catitalised and length 8 chars
If Not (Len(CStr(s.Range("f" & counter).Value)) = 8) Then
MsgBox "Incorrect Customer account number."
Exit Sub
End If
s.Range("f" & counter).Value = UCase(CStr(s.Range("f" & counter).Value))
' Column 'G' should be Numeric
s.Range("g" & counter).Value = CInt(Val(s.Range("g" & counter).Value))
' Column 'H' should be Numeric
s.Range("h" & counter).Value = CInt(Val(s.Range("h" & counter).Value))
' Column 'M' should contain a postcode with a space in it
' Or Eire
' Valid Postcode examples are:
' E1C 3GB (7 characters)
' PE28 4RT (8 characters)
' W4 6TF (6 characters)
postcode = REP(s.Range("m" & counter).Value, " ", "")
If ((postcode = "Eire") Or (postcode = "EIRE")) Then
postcode = UCase(postcode)
Else
' The third last digit of a postcode must be a number.
' regardless of what the format is:
If Not (IsNumeric(Mid(postcode, Len(postcode) - 2, 1))) Then
eMess = eMess & "Invalid Postcode in cell M" & counter & vbCrLf
Else
' Insert the space back in the correct position
If Len(postcode) = 7 Then
' Insert the space at the 5th position
postcode = UCase(Left(postcode, 4) & " " & Right(postcode, 3))
ElseIf Len(postcode) = 6 Then
' Insert the space at the 4th position
postcode = UCase(Left(postcode, 3) & " " & Right(postcode, 3))
ElseIf Len(postcode) = 5 Then
' Insert the space at the 3rd position
postcode = UCase(Left(postcode, 2) & " " & Right(postcode, 3))
End If
End If
End If
s.Range("m" & counter).Value = postcode
' Column 'R' should contain a Telephone number which should start with '0'
' and have 1 space at the 6th position to aid readability
If Not (Mid(telephone, 1, 1) = "0") Then
telephone = "0" & telephone
End If
telephone = REP(s.Range("r" & counter).Value, " ", "")
telephone = removeNonNumeric(telephone)
If (Len(telephone) = 10) Then
telephone = Left(telephone, 5) & " " & Right(telephone, 5)
ElseIf (Len(telephone) = 11) Then
telephone = Left(telephone, 5) & " " & Right(telephone, 6)
Else
eMess = eMess & "Invalid Telephone number in cell R" & counter & vbCrLf
End If
s.Range("r" & counter).Value = telephone
' Column 'S' could contain a Telephone number which should start with '0'
' and have 1 space at the 6th position to aid readability
If Not (IsEmpty(s.Range("s" & counter))) Then
If Not (Mid(telephone, 1, 1) = "0") Then
telephone = "0" & telephone
End If
telephone = REP(s.Range("s" & counter).Value, " ", "")
telephone = removeNonNumeric(telephone)
If (Len(telephone) = 10) Then
telephone = Left(telephone, 5) & " " & Right(telephone, 5)
ElseIf (Len(telephone) = 11) Then
telephone = Left(telephone, 5) & " " & Right(telephone, 6)
Else
eMess = eMess & "Invalid Telephone number in cell S" & counter & vbCrLf
End If
s.Range("s" & counter).Value = telephone
End If
' Column 'T' could contain a Telephone number which should start with '0'
' and have 1 space at the 6th position to aid readability
If Not (IsEmpty(s.Range("t" & counter))) Then
If Not (Mid(telephone, 1, 1) = "0") Then
telephone = "0" & telephone
End If
telephone = REP(s.Range("t" & counter).Value, " ", "")
telephone = removeNonNumeric(telephone)
If (Len(telephone) = 10) Then
telephone = Left(telephone, 5) & " " & Right(telephone, 5)
ElseIf (Len(telephone) = 11) Then
telephone = Left(telephone, 5) & " " & Right(telephone, 6)
Else
eMess = eMess & "Invalid Telephone number in cell T" & counter & vbCrLf
End If
s.Range("t" & counter).Value = telephone
End If
' Column 'V' should contain Date in format YYYMMDD
Columns("V:V").Select
Selection.NumberFormat = "@"
s.Range("v" & counter).Value = myDate
' Column 'W' if empty fil with a space
If (IsEmpty(s.Range("w" & counter).Value)) Then
s.Range("w" & counter).Value = " "
End If
' Column 'X' if empty fill with a space
If (IsEmpty(s.Range("x" & counter).Value)) Then
s.Range("x" & counter).Value = " "
End If
Next counter
' *************************************
' If we have errors then display them
' *************************************
If Not (eMess = "") Then
MsgBox "Incorrect Data in cells " & vbCrLf & eMess & vbCrLf & "Please correct the errors and try again."
Else
' **********************************************************
' If sheet is valid save it as a CSV(MSDOS) file then open
' an email 'send' window with the file as an attachment
' **********************************************************
Call SaveAsCSV
Call SendWithAtt
End If
End Sub
Function REP(Target As String, r As String, s As String)
' ******************************************************************************
' Function to replace a given string within another string with a third string
' ******************************************************************************
Dim temp As String
Dim n As Integer
temp = ""
For n = 1 To Len(Target)
If Mid(Target, n, 1) = r Then
temp = temp & s
Else
temp = temp & Mid(Target, n, 1)
End If
REP = temp
Next n
End Function
Function removeNonNumeric(pNumber As String) As String
' *******************************************************
' Function to return only the numeric chars in a string
' *******************************************************
Dim returnNumber As String
Dim testChar As String
Dim count As Integer
'cycle through message string
For count = 1 To Len(pNumber)
testChar = Mid(pNumber, count, 1)
If IsNumeric(testChar) Then returnNumber = returnNumber & testChar
Next count
removeNonNumeric = returnNumber
End Function
Sub New_Menu()
' *********************************************************
' Subroutine to create the menu, submenu and menu divider
' *********************************************************
Dim newSubItem As Object
CommandBars("Worksheet Menu Bar").Controls("Tools").Controls.Add(Type:=msoControlPopup).Caption = "New Orders Tools"
CommandBars("Worksheet Menu Bar").Controls("Tools").Controls("New Orders Tools").BeginGroup = True
Set newSubItem = CommandBars("Worksheet Menu Bar").Controls("Tools").Controls("New Orders Tools")
With newSubItem
.Controls.Add(Type:=msoControlButton).Caption = "Validate Sheet"
.Controls("Validate Sheet").OnAction = "validate"
End With
End Sub
Sub Delete_Menu()
' *********************************************************
' Subroutine to delete the menu divider, menu and submenu
' *********************************************************
CommandBars("Worksheet Menu Bar").Controls("Tools").Controls("New Orders Tools").Delete
End Sub
Sub SendWithAtt()
' ***************************************************
' Subroutine to open an email window with the sheet
' attached so we can run the file transfer option
' ***************************************************
Dim olApp As Outlook.Application
Dim olMail As MailItem
Dim CurrFile As String
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
ActiveWorkbook.Save
CurrFile = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With olMail
.Subject = "New Orders From Account Number " & ActiveSheet.Range("f2").Value
.Attachments.Add CurrFile
.Display
End With
Set olMail = Nothing
Set olApp = Nothing
End Sub
Sub SaveAsCSV()
' *****************************************************
' Subroutine to open a SaveAs dialog box with a CSV
' filter so we can save the file as a CSV(MSDOS) file
' *****************************************************
MsgBox "There are no validation errors in the sheet." & vbCrLf & "Please save the file as a CSV(MSDOS) file."
Application.Dialogs(xlDialogSaveAs).Show arg1:=".csv", arg2:=xlCSVMSDOS
End Sub
' ************************************************************************************************************************
' ********************************************************
' The next section is not part of the validation program
' ********************************************************
' **********************************************************************
' Routine for breaking the password protection on an excel spreadsheet
' This is a brute force solution if you forget your password
' **********************************************************************
Sub PasswordBreaker()
Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer
On Error Resume Next
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If ActiveSheet.ProtectContents = False Then
MsgBox "One usable password is " & Chr(i) & Chr(j) & _
Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
Exit Sub
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
End Sub
' ************************************************************************************************************************
