Streamlining and improving VBA Code


Posted by Dominic on June 07, 2001 7:24 AM

I have the following code below, which uses the vlookup in a referenced table to provide data. Could you VBA experts just have a look at it and tell me if there are any improvements that can be done.

For instance in the Userform, I have specified Match in the Comboboxes , and if someone makes an error and chooses to try to reset or close when the " Invalid Entry" msg is showing he cant. He can only exit using the Userform " X " button. Thanks

Option Explicit
Dim vDichte, vMenge, vConv, vErgebnisA, vErgebnisB, vErgebnisC, vErgebnisD, vVE, vEE, vNE, vE As Variant
Dim ctlWork As Control
Dim bTest As Boolean
Sub Show()
UserForm1.Show
End Sub

Sub Set_RowSource()
' Clears unnecessary Fields
UserForm1.Einheit.Text = ""
UserForm1.Ergebnis.Value = ""
UserForm1.NachEin.Value = ""
UserForm1.Bemerkung.Text = ""
' Controls the Row Source of Umrechnungseinheit
If UserForm1.VonEin.Value = "Liter" Then UserForm1.NachEin.RowSource = "Daten!Liter"
If UserForm1.VonEin.Value = "Gallone" Then UserForm1.NachEin.RowSource = "Daten!Gallone"
If UserForm1.VonEin.Value = "Pound" Then UserForm1.NachEin.RowSource = "Daten!Pound"
If UserForm1.VonEin.Value = "Kilogramm" Then UserForm1.NachEin.RowSource = "Daten!Kilogramm"
End Sub

Sub Rechnen()
' uses boolean so as not to repeat the test for every field , boolean is set to true in Msg
bTest = False
For Each ctlWork In UserForm1.Controls
If bTest = True Then GoTo Finalline
If TypeOf ctlWork Is ComboBox Then
If ctlWork.Text = "" Then Msg
End If
Next
' Send input Product and Von Einheit to Excel sheet for data determination
On Error Resume Next
Sheets("Daten").Range("ProduktWahl") = UserForm1.Produkt
Sheets("Daten").Range("NachEinWahl") = UserForm1.NachEin
Sheets("Daten").Range("Menge") = UserForm1.Menge.Value
' Collects determined Data from Excel Sheet and sets Variable values
vDichte = Sheets("Daten").Range("DichteWahl")
vConv = Sheets("Daten").Range("FaktorConv")
vMenge = Sheets("Daten").Range("MengeCo")

On Error Resume Next
' Creates and names formulas
vErgebnisA = vMenge * vDichte * vConv
vErgebnisB = vMenge / vDichte * vConv
vErgebnisC = vMenge * vConv
vErgebnisD = vMenge / vDichte
Sheets("Daten").Range("RundenErgebnis_A") = Str$(vErgebnisA)
Sheets("Daten").Range("RundenErgebnis_B") = Str$(vErgebnisB)
Sheets("Daten").Range("RundenErgebnis_C") = Str$(vErgebnisC)
Sheets("Daten").Range("RundenErgebnis_D") = Str$(vErgebnisD)
' Determines via Sverweis in Excel which Formula to use
If Sheets("Daten").Range("Formel").Value = "A" Then UserForm1.Ergebnis = Sheets("Daten").Range("GrunErgebA")
If Sheets("Daten").Range("Formel").Value = "B" Then UserForm1.Ergebnis = Sheets("Daten").Range("GrunErgebB")
If Sheets("Daten").Range("Formel").Value = "C" Then UserForm1.Ergebnis = Sheets("Daten").Range("GrunErgebC")
If Sheets("Daten").Range("Formel").Value = "D" Then UserForm1.Ergebnis = Sheets("Daten").Range("GrunErgebD")

UserForm1.Bemerkung.Text = Sheets("Daten").Range("Bemerkung")
' Replaces the > Unit with "" for display purposes
vNE = UserForm1.VonEin.Text
vVE = UserForm1.NachEin.Text

vE = WorksheetFunction.Substitute(vVE, vNE, "")
vEE = WorksheetFunction.Substitute(vE, ">", "")
UserForm1.Einheit.Text = vEE
If Err.Number <> 0 Then ErrMsg
Finalline:
End Sub

Sub ResetForm()
For Each ctlWork In UserForm1.Controls
If TypeOf ctlWork Is ComboBox Or TypeOf ctlWork Is MsForms.TextBox Then
ctlWork.Text = ""
End If
Next
End Sub
Sub Msg()
MsgBox "Bitte alle Felder ausfüllen", vbOKOnly
bTest = True
End Sub
Sub ErrMsg()
MsgBox " Fehler bei der Eingabe. Bitte stellen Sie fest," & Chr(13) & " dass Ihre Eingabe in folgenden Format ist" & Chr(13) & "" & Chr(13) & "123456,00 oder 123456.00", vbCritical
ResetForm
End Sub

Sub Auto_Open()
Range("g27").Select
Sheets("Einheitsumrechnung").ScrollArea = "a1:k35"
End Sub



Posted by Joe Was on June 08, 2001 8:43 PM

Dom,
You can trap for user button or response with Case statements, this code sample may help you?

Sub Search_Complex_Code()
Dim Temp As String
Dim Tsearch As String
Dim Numsub
Dim Mcan
Temp = Application.InputBox(Prompt:="Please enter the Complexity Code to search for;" & Chr(13) & "Use a [ 7 digit search code ], only!" & Chr(13) & "You may use [ ? ] as a place holders, for digits which are not important!" & Chr(13) & "Example: ?G?????, [6 codes, 7 digits, ODA = 2 digits!]", Title:="Enter the Complexity Code to Lookup!", Type:=2)

If Temp = "False" Then
Numsub = 2

ElseIf Temp = "" Then
Numsub = 3

Else
Numsub = 1
End If

Select Case Numsub

Case 1
Tsearch = "" = " & Temp & """
With Worksheets("Load")
.AutoFilterMode = False
.Rows(5).AutoFilter
.Rows(5).AutoFilter Field:=6, Criteria1:=Temp, VisibleDropDown:=False
.UsedRange.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("Search").Cells(1, 1)
Application.CutCopyMode = False
.AutoFilterMode = False
End With
Sheets("Search").Select
Range("A1").Select

Case 2
Sheets("Search").Select
Range("A1:A6").Select
Selection.EntireRow.Delete
Range("A1").Select
Sheets("Load").Select
Range("A1").Select


Case 3
Mcan = MsgBox("Search Canceled, search criteria is Blank?", vbOKOnly, "BLANK SEARCH!")
Sheets("Search").Select
Range("A1:A6").Select
Selection.EntireRow.Delete
Range("A1").Select
Sheets("Load").Select
Range("A1").Select

End Select
End Sub

Case 1 is the program, Case 2 is the Cancel button and Case 3 is a bad entry. Case 2 & 3 also include code to clean up any partial or incomplete macro printing.

The above sample code displays a user box which will search a sheet for what ever is inputed and will accept wild card place holders. It cancels the search if the user presses OK before entering a search perameter and will clean and close on Cancel.

Your code looks good, I did not test it, but it look clean. If my ERROR Case code helps you or not I don't know?
Bitte.