AW: Bezug zu anderen Dateien herstellen
05.08.2014 11:21:16
fcs
Hallo Barbara,
hier Makros, die du in deine Eingabedatei einbauen muss.
Die Makros zum Öffnen/Schließen der Berechnungsdatei kannst du dann Schaltflächen aus den Formular-Steuerelementen zuweisen.
Pfad und Name der jeweils geöffneten Berechnungsdatei werden in "Tabelle2" eingetragen. Wenn du diese Infos im Eingabeblatt haben willst, dann musst du den Blattnamen und die Zelladressen in allen relevanten Code-Zeilen anpassen.
Gruß
Franz
'Makros in einem allgemeinen Modul der Eingabedatei
Sub Berechnungsdatei_Oeffnen()
Dim varDatei As Variant
Dim wkb As Workbook
Dim wksMerk As Worksheet
'Tabellenblatt in dem Pfad und Name der geöffneten Berechnungsdatei eingetragen werden
Set wksMerk = ThisWorkbook.Worksheets("Tabelle2")
If wksMerk.Range("B3") "" Then
MsgBox "Es ist evtl. noch die Datei """ & wksMerk.Range("B3") _
& """ geöffnet, bitte erst diese Datei schliessen"
Else
With Application.FileDialog(msoFileDialogOpen)
.Title = "Bitte Berechnungsdatei auswählen und öffnen"
.AllowMultiSelect = False
If .Show = -1 Then
varDatei = .SelectedItems(1)
'Berechnungsdatei schreibgeschützt öffnen
Set wkb = Application.Workbooks.Open(Filename:=varDatei, ReadOnly:=True, _
addtomru:=False)
wksMerk.Range("B2") = wkb.Path
wksMerk.Range("B3") = wkb.Name
ThisWorkbook.Activate
Else
'do nothing - Dateiauswahl abgebrochen
End If
End With
End If
End Sub
Sub Berechnungsdatei_Schliessen()
Dim wkb As Workbook
Dim wksMerk As Worksheet
'Tabellenblatt in dem Pfad und Name der geöffneten Berechnungsdatei eingetragen werden
Set wksMerk = ThisWorkbook.Worksheets("Tabelle2")
If wksMerk.Range("B3") "" Then
For Each wkb In Application.Workbooks
If wkb.Name = wksMerk.Range("B3") Then
wkb.Close savechanges:=False
Exit For
End If
Next
wksMerk.Range("B2").ClearContents
wksMerk.Range("B3").ClearContents
Else
MsgBox "In Tabelle """ & wksMerk.Name _
& """ ist in Zelle B3 kein Dateiname eingetragen"
End If
End Sub
Sub Berechnen()
Dim wkb As Workbook
Dim wksMerk As Worksheet
Dim wksEingabe As Worksheet
Dim wksRechnen As Worksheet
Dim strMsg As String
'Tabellenblatt in dem Pfad und Name der geöffneten Berechnungsdatei eingetragen werden
Set wksMerk = ThisWorkbook.Worksheets("Tabelle2")
Set wksEingabe = ActiveSheet
If wksMerk.Range("B3").Value "" Then
'Berechnungsdatei unter den geöffneten Dateien suchen
For Each wkb In Application.Workbooks
If wkb.Name = wksMerk.Range("B3").Value Then
Exit For
End If
Next
If wkb Is Nothing Then
MsgBox "Die in Tabelle """ & wksMerk.Name _
& """ in Zelle B3 eingetragene Datei ist nicht geöffnet." _
& "Bitte erst Berechnungsdatei öffnen"
wksMerk.Range("B2").ClearContents
wksMerk.Range("B3").ClearContents
Else
'Eingabewerte prüfen - vorhandene Werte/Wertebereiche
With wksEingabe
strMsg = ""
With .Range("A2") 'Laufzeit
If .Value = "" Then
strMsg = strMsg & vbLf & "Es ist keine Laufzeit in A2 eingetragen"
ElseIf .Value 600 Then
strMsg = strMsg & vbLf & "Laufzeit in A2 ist außerhalb Bereich 1 bis 600"
End If
End With
With .Range("A3") 'Rabatt
If .Value = "" Then
strMsg = strMsg & vbLf & "Es ist kein Rabatt in A3 eingetragen"
ElseIf .Value 1 Then
strMsg = strMsg & vbLf & "Rabatt in A3 muss im Bereich 0% bis 100% "
End If
End With
End With
If strMsg "" Then
MsgBox "Eingabefehler:" & strMsg, vbInformation + vbOKOnly, "Prüfung Eingabewerte"
Exit Sub
End If
Set wksRechnen = wkb.Worksheets(1)
'Eingabe-Werte in Berechnungsblatt eintragen
Application.Calculation = xlCalculationManual
wksRechnen.Range("B4").Value = wksEingabe.Range("A2").Value 'Laufzeit
wksRechnen.Range("B5").Value = wksEingabe.Range("A3").Value 'Rabatt
Application.Calculate
'Ergebnis in Eingabeblatt übernehmen
wksEingabe.Range("A4") = wksRechnen.Range("B6").Value 'Ergebnis - Miete
Application.Calculation = xlCalculationAutomatic
End If
Else
MsgBox "In Tabelle """ & wksMerk.Name _
& """ ist in Zelle B3 kein Dateiname eingetragen. " _
& "Bitte erst Berechnungsdatei öffnen"
End If
End Sub
'Code im VBA-Editor unter dem Eingabe-Tabellenblatt
Private Sub Worksheet_Change(ByVal Target As Range)
'Startet automatisch Berechnung wenn einer der Eingabewerte geändert wird
Select Case Target.Address(False, False, xlA1)
Case "A2", "A3"
If Not IsEmpty(Range("A2")) And Not IsEmpty(Range("A3")) Then
Call Berechnen
End If
End Select
End Sub
'Code im VBA-Editor unter dem Eingabe-Tabellenblatt
Private Sub Worksheet_Change(ByVal Target As Range)
'Startet automatisch Berechnung wenn einer der Eingabewerte geändert wird
Select Case Target.Address(False, False, xlA1)
Case "A2", "A3"
If Not IsEmpty(Range("A2")) And Not IsEmpty(Range("A3")) Then
Call Berechnen
End If
End Select
End Sub