Automatische Berechnung - Excel-Makro

Option Explicit

  Private Const RANGE_ERGEBNIS_VON_ZEILE = 25
  Private Const RANGE_ERGEBNIS_BIS_ZEILE = 28

  Private Const ZEILE_ZIEL_ERGEBNIS = 14

  Private Const RANGE_DATENQUELLE_VON_ZEILE = 3
  Private Const RANGE_DATENQUELLE_BIS_ZEILE = 12
  
  Private Const RANGE_DATENZIEL_ZEILE = 3

  Private Const cTXT_FRAGE_DATEN_AUS_WELCHER_SPALTE = _
                Aus welcher Spalte sollen die Daten kopiert werden ? & vbLf & _
                Bitte geben Sie den Buchstaben der Spalte ein.
  Private Const cTXT_FRAGE_ERGEBNIS_IN_WELCHER_SPALTE = _
                In welche Spalte sollen die Ergebnis-Daten kopiert werden ? & vbLf & _
                Bitte geben Sie den Buchstaben der Spalte ein.
'**********************************************************************
Sub Daten_InSpalte_B_Kopieren()
  Call Daten_InSpalte_Kopieren(B)
End Sub
'**********************************************************************
Sub Daten_InSpalte_C_Kopieren()
  Call Daten_InSpalte_Kopieren(C)
End Sub
'**********************************************************************
Private Function Daten_InSpalte_Kopieren(sZielspalte As String)
  
  Dim sSpalte As String
  
  If Not SpaltenEingabe(sSpalte, _
                        cTXT_FRAGE_DATEN_AUS_WELCHER_SPALTE, _
                        Daten kopieren in Spalte  & sZielspalte _
                        ) Then Exit Function
  
  Range(sSpalte & RANGE_DATENQUELLE_VON_ZEILE & : & _
        sSpalte & RANGE_DATENQUELLE_BIS_ZEILE).Copy
  Range(sZielspalte & RANGE_DATENZIEL_ZEILE).Select
  Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
                         SkipBlanks:=False, Transpose:=False
End Function
'**********************************************************************
Sub Ergebnis_SpalteB_Kopieren()
  Call Ergebnis_Spalte_Kopieren(B)
End Sub
'**********************************************************************
Sub Ergebnis_SpalteC_Kopieren()
  Call Ergebnis_Spalte_Kopieren(C)
End Sub
'**********************************************************************
Private Function Ergebnis_Spalte_Kopieren(sQuellSpalte As String)
  
  Dim sSpalte As String
  
  If Not SpaltenEingabe(sSpalte, _
                        cTXT_FRAGE_ERGEBNIS_IN_WELCHER_SPALTE, _
                        Daten kopieren aus Spalte  & sQuellSpalte _
                        ) Then Exit Function
  
  Range(sQuellSpalte & RANGE_ERGEBNIS_VON_ZEILE & : & _
        sQuellSpalte & RANGE_ERGEBNIS_BIS_ZEILE).Copy
  Range(sSpalte & ZEILE_ZIEL_ERGEBNIS).Select
  Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
                         SkipBlanks:=False, Transpose:=False
End Function
'**********************************************************************
Private Function SpaltenEingabe(sSpalte As String, _
                                sPrompt As String, _
                                sTitle As String) As Boolean
  SpaltenEingabe = False
  sSpalte = 
  Do
    sSpalte = InputBox(sPrompt, sTitle, sSpalte)
    If sSpalte =  Then Exit Function->Abbruch oder terminate
    sSpalte = UCase(sSpalte)
    Select Case sSpalte
      Case F, G, H, I, J:  SpaltenEingabe = True: Exit Do->zulässig
      Case Else: MsgBox Spaltenangabe-> & sSpalte &-> unzlässig.
    End Select
  Loop
End Function

Option Explicit

 ->Berechnungsbereich
  Private Const SPALTE_BERECHNUNG_B = 2
  Private Const ZEILE_VON_BERECHNUNG_DATEN1 = 3
  Private Const ZEILE_BIS_BERECHNUNG_DATEN1 = 12
  Private Const ZEILE_VON_BERECHNUNG_ERGEBNIS = 25
  Private Const ZEILE_BIS_BERECHNUNG_ERGEBNIS = 28
  
 ->Datenspeicherbereich
  Private Const SPALTE_AB_DATENSPEICHER = 6
  Private Const ZEILE_VON_DATENSPEICHER_DATEN1 = 3
  Private Const ZEILE_BIS_DATENSPEICHER_DATEN1 = 12
  Private Const ZEILE_VON_DATENSPEICHER_ERGEBNIS = 14
  Private Const ZEILE_BIS_DATENSPEICHER_ERGEBNIS = 17

Sub DatenKopierenBerechnenErgebnisZurueckKopieren()

  Dim lSpSpeicher As Long

 ->Solange Spalten mit Daten im Speicherbereich vorhanden sind
  lSpSpeicher = SPALTE_AB_DATENSPEICHER
  Do
   ->keine weiteren Daten im Datenspeicher?
    If Cells(ZEILE_VON_DATENSPEICHER_DATEN1, lSpSpeicher).Value =  Then Exit Do
    
   ->Daten aus Datenspeicher in Berechnungsbereich kopieren
    Range(Cells(ZEILE_VON_DATENSPEICHER_DATEN1, lSpSpeicher), _
          Cells(ZEILE_BIS_DATENSPEICHER_DATEN1, lSpSpeicher)).Copy
    Range(Cells(ZEILE_VON_BERECHNUNG_DATEN1, SPALTE_BERECHNUNG_B), _
          Cells(ZEILE_VON_BERECHNUNG_DATEN1, SPALTE_BERECHNUNG_B)).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
                           SkipBlanks:=False, Transpose:=False
                           
   ->Berechnung anstossen
    Calculate

   ->Ergebnisse aus dem Berechnungsbereich in den Datenspeicherbereich kopieren
    Range(Cells(ZEILE_VON_BERECHNUNG_ERGEBNIS, SPALTE_BERECHNUNG_B), _
          Cells(ZEILE_BIS_BERECHNUNG_ERGEBNIS, SPALTE_BERECHNUNG_B)).Copy
    Range(Cells(ZEILE_VON_DATENSPEICHER_ERGEBNIS, lSpSpeicher), _
          Cells(ZEILE_VON_DATENSPEICHER_ERGEBNIS, lSpSpeicher)).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
                           SkipBlanks:=False, Transpose:=False
    
   ->nächste Spalte Datenspeicher
    lSpSpeicher = lSpSpeicher + 1
  Loop
End Sub