VBA Code Problem - Zielwertsuche mit VBA
26.11.2013 14:07:49
Ralf
ich habe in einer Arbeitsmappe eine Zielwertsuche mit VBA eingebaut.
Folgenden Code habe dafür mit Makrorekorder aufgezeichnet:
Sub Zielwertsuche_Stückzahl()
'Bildschirmaktualisierung aus
Application.ScreenUpdating = False
Sheets("Umlage").Select
Call Tabellenblatt_entsperren
Range("B29").Select
ActiveCell.FormulaR1C1 = "100000"
Dim Mldg1 As String, Titel1 As String, Wert1
Dim Mldg2 As String, Titel2 As String, Wert2
Dim Mldg3 As String, Titel3 As String, Wert3
Select Case Worksheets("Sprachauswahl").Range("C10")
Case 1: Mldg1 = "Bitte die Umlage eintragen. Die zugehörige Umlagestückzahl wird errechnet." _
Case 2: Mldg1 = ""
Case Else
End Select
Select Case Worksheets("Sprachauswahl").Range("C10")
Case 1: Mldg2 = "Bitte die Anzahl der Umlagejahre angeben."
Case 2: Mldg2 = ""
Case Else
End Select
Select Case Worksheets("Sprachauswahl").Range("C10")
Case 1: Mldg3 = "Bitte den Instandhaltungssatz in Prozent angeben."
Case 2: Mldg3 = ""
Case Else
End Select
Select Case Worksheets("Sprachauswahl").Range("C10")
Case 1: Titel1 = "Zielwert für Umlage"
Case 2: Titel1 = ""
Case Else
End Select
Select Case Worksheets("Sprachauswahl").Range("C10")
Case 1: Titel2 = "Umlagejahre"
Case 2: Titel2 = ""
Case Else
End Select
Select Case Worksheets("Sprachauswahl").Range("C10")
Case 1: Titel3 = "Instandhaltung"
Case 2: Titel3 = ""
Case Else
End Select
Wert1 = InputBox(Mldg1, Titel1)
If Wert1 = "" Or Not IsNumeric(Wert1) Then GoTo Beenden
Wert2 = InputBox(Mldg2, Titel2)
If Wert2 = "" Or Not IsNumeric(Wert1) Then GoTo Beenden
Wert3 = InputBox(Mldg3, Titel3)
If Wert3 = "" Or Not IsNumeric(Wert1) Then GoTo Beenden
'für Excel 2007
If AddIns("Solver").Installed = False Then
AddIns("Solver").Installed = True
End If
'Set Solv = AddIns("Solver Add-In")
'If Solv.Installed = False Then
'AddIns("Solver Add-in").Installed = True
'End If
'für Excel 2010
'AddIns("Solver").Installed = True
With Application
.Iteration = True
.MaxIterations = 32767
.MaxChange = 0.000001
End With
Range("B15") = Wert2
Range("B18") = Wert3 / 100
Range("E34").GoalSeek Goal:=CDbl(Wert1), ChangingCell:=Range("B29")
'Ergebniszelle => Range("E34").goalseek
'Zielwert => Goal:=Wert1
'Variable Zelle => ChangingCell:=Range("B29")
Beenden:
Range("B21:B28").Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Locked = True
Selection.FormulaHidden = False
Range("B29").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
Selection.Locked = False
Selection.FormulaHidden = False
Range("C29").Select
'=WENN(B29=F29;"";"Einzelvolumen unberücksichtigt!")
ActiveCell.FormulaR1C1 = "=IF(RC[-1]=RC[3],"""",""Einzelvolumen unberücksichtigt!"")"
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.InsertIndent 1
Call Tabellenblatt_sperren
Range("A1").Select
End Sub
Nun bekomme ich in der Zeile
.ThemeColor = xlThemeColorDark1
einen Laufzeitfehler:
Laufzeitfehler '1004':
Anwendungs- oder objektdefinierter Fehler
Fortfahren (ausgegraut) Beenden Debuggen Hilfe
Kann mir jemand helfen, und mitteilen woran dies liegen könnte?
Vielen Dank im Voraus für eine Rückmeldung.
Viele Grüße
Ralf