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