Hallo Oliver,
die anzuwendende Lösung hängt stark davon ab in welcher Datei/Tabelle die Ausgangsfaktoren für die Berechnung eingegeben/ausgewählt werden. Geldwertberechnung oder separate Tabelle.
Sind alle Ausgangswerte bereits in der Geldwertberechnung eingegeben/vorhanden, dann kann man diese "einfach" per Wertzuweisung in die Eingabezellen der separaten Tabelle übertragen. Anschließend dann die Ergebnisse aus der separaten Tabelle in die Geldwertberechnung übertragen.
Beispiel Makro:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim wbCalc As Workbook, wksCalc As Worksheet, rngErgebnis As Range
Select Case Target.Address
Case "$C$8"
Set rngErgebnis = Target 'Zelle für Ergebnis merken
Application.ScreenUpdating = False
Set wbCalc = Workbooks.Open(Filename:="\\S123445\P12345$\Berechnung.xls", _
ReadOnly:=True)
Set wksCalc = wbCalc.Worksheets("Berechnung")
'Parameter eintragen
wksCalc.Range("B4").Value = Me.Range("C4").Value 'Wert A
wksCalc.Range("B8").Value = Me.Range("C5").Value 'Wert B
'Berechnungsblatt neu berechnen
wksCalc.Calculate
'Werte zurückübertragen
rngErgebnis.Value = wksCalc.Range("B12").Value
'berechnung ohne speichern wieder schließen
wbCalc.Close savechanges:=False
Application.ScreenUpdating = True
Cancel = True 'Bearbeitung in doppelgeklickter Zelle wird abgebrochen
Case Else
'do nothing
End Select
End Sub
Sind die Ausgangsfaktoren in der Geldwertberechnung noch nicht vorhanden, dann kann man diese z.B. über Inputboxen eingeben. Bei vielen Werten und z.B. Auswahl per DropDown-Listen oder Optionen wäre ein Userform die elegantere Lösung.
Beispiel mit Eingabe via Inputboxen:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim wbCalc As Workbook, wksCalc As Worksheet, rngErgebnis As Range
Dim varEingabe, strBoxTitel As String
Select Case Target.Address
Case "$C$8"
strBoxTitel = "Eingaben für Berechnung"
Set rngErgebnis = Target 'Zelle für Ergebnis merken
Set wbCalc = Workbooks.Open(Filename:="\\S123445\P12345$\Berechnung.xls", _
ReadOnly:=True)
Set wksCalc = wbCalc.Worksheets("Berechnung")
'Parameter eintragen
'Wert A - Zahl
varEingabe = Application.InputBox(Prompt:="Wert A?", _
Title:=strBoxTitel & " - Wert A", _
Default:=0, _
Type:=1)
If varEingabe = False Then GoTo EingabeAbbrechen
wksCalc.Range("B4").Value = varEingabe 'Wert A
'Wert B - Zahl
varEingabe = Application.InputBox(Prompt:="Wert B?", _
Title:=strBoxTitel & " - Wert B", _
Default:=5, _
Type:=1)
If varEingabe = False Then GoTo EingabeAbbrechen
wksCalc.Range("B8").Value = varEingabe 'Wert A
'Wert C -Text
varEingabe = Application.InputBox(Prompt:="Wert C?", _
Title:=strBoxTitel & " - Wert C", _
Default:="A", _
Type:=2)
If varEingabe = False Then GoTo EingabeAbbrechen
wksCalc.Range("B9").Value = varEingabe 'Wert B
'Berechnungsblatt neu berechnen
wksCalc.Calculate
'Werte zurückübertragen
rngErgebnis.Value = wksCalc.Range("B12").Value
'berechnung ohne speichern wieder schließen
EingabeAbbrechen:
wbCalc.Close savechanges:=False
Cancel = True 'Bearbeitung in doppelgeklickter Zelle wird abgebrochen
Case Else
'do nothing
End Select
End Sub
Eine weitere Möglichkeit:
Nach dem Doppelklick wird "nur" die Berechnungsdatei gestartet und die doppelgeklickte Zelle bleibt die aktive Zelle.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim wbCalc As Workbook, wksCalc As Worksheet, rngErgebnis As Range
On Error Resume Next
Select Case Target.Address
Case "$C$8"
Workbooks.Open Filename:="\\S123445\P12345$\Berechnung.xls", _
ReadOnly:=True
Cancel = True 'Bearbeitung in doppelgeklickter Zelle wird abgebrochen
Case Else
'do nothing
End Select
End Sub
In der separaten Berechnungsdatei wird zum Übertragen des Ergebnisses ein Makro in der Datei gestartet in dem die Zieldatei für das Ergebnis ausgewählt wird.
Sub ErgebnisUebertragen()
Dim wbThis As Workbook, wksCalc As Worksheet, arrWb() As String
Dim wbGeldwert As Workbook, intI As Integer
Dim strBoxTitel As String, strMsgText As String, varAuswahl
Set wbThis = ThisWorkbook
Set wksCalc = wbThis.Worksheets("Berechnung")
strBoxTitel = "Berechnungsergebnis übertragen in Geldwertberechnung"
'Arbeitsmappennamen einlesen
strMsgText = "Bitte Nr der Arbeitsmappe auswählen, " _
& "in die Ergebnis eingetragen werden soll." & vbLf
intI = 0
For Each wbGeldwert In Application.Workbooks
If wbGeldwert.Name = wbThis.Name Then
'do nothing
ElseIf Left(LCase(wbGeldwert.Name), 6) = "person" Then
'do nothing
Else
intI = intI + 1
ReDim Preserve arrWb(1 To intI)
arrWb(intI) = wbGeldwert.Name
strMsgText = strMsgText & vbLf & wbGeldwert.Name
End If
Next
Auswahl:
varAuswahl = Application.InputBox(Prompt:=strMsgText, Title:=strBoxTitel, _
Default:=1, Type:=1)
If varAuswahl = False Then GoTo Abbrechen
If varAuswahl intI Then
MsgBox "Ausgewählte Nummer nicht zulässig!"
GoTo Auswahl
End If
'Ergebniss eintragen
Workbooks(arrWb(varAuswahl)).Activate
ActiveCell.Value = wksCalc.Range("b12").Value
Abbrechen:
wbThis.Close savechanges:=False
End Sub
Gruß
Franz
(ein anderer als bei 1. Antwort)