Option Explicit
-><<< A N P A S S E N >>>
->Quelle - Bereich der in den Formeln abgearbeitet werden soll
Const AbzuarbeitenderBereich = B2:C10
->Ziel
Const cZ_ERSTEEINTRAGSZEILE = 2->ab Zeile Formeln eintragen
Const cBLTNAME_ANFANG = KW ->BlattNamen der Bezugsblätter ohne zweistellige KWNr
-><<< A N P A S S E N E N D E >>>
Sub FormelKWxxBxUndCxInSpalteAbZeile2()
->*** Formeln automatisiert eingeben
->***
->*** Beispiel:
->*** Zeile 2: =KW32!$B$2
->*** Zeile 3: =KW32!$C$2
->*** Zeile 4: =KW32!$B$3
->*** Zeile 5: =KW32!$C$3
->*** ....
->***
->*** a) vor dem Aufruf des Makros ist die Zelle in Zeile 2
->*** der entsprechenden Spalte zu markieren (wird geprüft)
->***
->*** b) beim Start wird der einzufügende Blattname abgefragt
->*** (Vorlage, wenn möglich, aus vorhergehender Spalte)
->***
->*** c) die Formeln werden ab Zeile 2 auf dem aktiven Blatt eingefügt
->*** (Blatt muß das aktive Blatt sein)
->***
->*** d) alle benötigten Zellen müssen leer sein
->*** (wird überprüft -> Makro kann nichts überschreiben)
->***
->*** e) das jeweilige Verweisblatt KWxx muß vorhanden sein
->*** (wird überprüft - sonst gibt es beim Einfügen einen Fehler)
->***
Dim wb As Workbook, ws As Worksheet
Dim lSpalte As Long, sBltKW As String
->aktiveMappe / aktives Blatt setzen
Set wb = ActiveWorkbook
Set ws = ActiveSheet
->Selection prüfen: 1 Zelle in Zeile 2
->selektierte Spalte feststellen
If Not SelectionPruefen(lSpalte) Then GoTo AUFRAEUMEN
->zu beschreibende Zellen auf leer prüfen
If Not ZellenAufLeerPruefen(ws, lSpalte, AbzuarbeitenderBereich) Then GoTo AUFRAEUMEN
->Blattname KW aus der Spalte vorher ableiten
->Wenn nicht möglich, durch Defaultnamen ersetzen
sBltKW = BlattnameKWAusVorigerSpalteAbleiten(ws, lSpalte)
->Blattnamen vorlegen zur Bestätigung, Resultat auf Existenz prüfen
If Not BlattnamenBestaetigungResultatPruefen(wb, sBltKW) Then GoTo AUFRAEUMEN
->Formeln eintragen
Call FormelnEintragen(ws, lSpalte, AbzuarbeitenderBereich, sBltKW)
AUFRAEUMEN:
Set wb = Nothing: Set ws = Nothing
End Sub
'*******************************************************************************
Private Function FormelnEintragen(ws As Worksheet, lSpalte As Long, _
AbzuarbeitenderBereich As String, sBltKW As String)
->Formeln eintragen
Dim Zelle As Range
Dim lSpaltenAbzuarbeitenderBereich As Long, lZeilenAbzuarbeitenderBereich As Long
Dim z As Long, sp As Long, lZeile As Long, sFormel As String
lSpaltenAbzuarbeitenderBereich = ws.Range(AbzuarbeitenderBereich).Columns.Count
lZeilenAbzuarbeitenderBereich = ws.Range(AbzuarbeitenderBereich).Rows.Count
->linke, obere Zelle des AbzuarbeitenderBereich setzen
Set Zelle = ws.Range(Cells(ws.Range(AbzuarbeitenderBereich).Row, ws.Range(AbzuarbeitenderBereich).Column), _
Cells(ws.Range(AbzuarbeitenderBereich).Row, ws.Range(AbzuarbeitenderBereich).Column))
lZeile = cZ_ERSTEEINTRAGSZEILE
For z = 0 To lZeilenAbzuarbeitenderBereich - 1
For sp = 0 To lSpaltenAbzuarbeitenderBereich - 1
sFormel = = & sBltKW & ! & Zelle.Offset(z, sp).Address
ws.Cells(lZeile, lSpalte).Formula = sFormel
lZeile = lZeile + 1
Next
Next
AUFRAEUMEN:
Set Zelle = Nothing
End Function
'*******************************************************************************
Private Function BlattnamenBestaetigungResultatPruefen(wb As Workbook, sBltKW As String) As Boolean
->Blattnamen vorlegen zur Bestätigung, Resultat auf Existenz prüfen
Dim wsq As Worksheet
BlattnamenBestaetigungResultatPruefen = False
sBltKW = InputBox(Bitte geben Sie den KW-Blattnamen ein. & vbLf & _
(Form: & cBLTNAME_ANFANG & xx xx=Kalenderwoche zweistellig), _
Eingabe KW-Blattname, sBltKW)
On Error Resume Next
Set wsq = wb.Worksheets(sBltKW)
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
If wsq Is Nothing Then MsgBox Blattname-> & sBltKW &->existiert nicht.: GoTo AUFRAEUMEN
BlattnamenBestaetigungResultatPruefen = True
AUFRAEUMEN:
Set wsq = Nothing
End Function
'*******************************************************************************
Private Function BlattnameKWAusVorigerSpalteAbleiten(ws As Worksheet, lSpalte As Long) As String
->Blattname KW aus der Spalte vorher ableiten
->Wenn nicht möglich, durch Defaultnamen ersetzen
Dim sKW As String, sKWNr As String, lKWNr As Long, sFormel As String
sKW = cBLTNAME_ANFANG & 01
If lSpalte > 1 Then
sFormel = ws.Cells(cZ_ERSTEEINTRAGSZEILE, lSpalte - 1).Formula
If Left(sFormel, Len(cBLTNAME_ANFANG) + 1) = = & cBLTNAME_ANFANG Then
->alte KWNr feststellen (zweistellig)
sKWNr = Mid(sFormel, Len(cBLTNAME_ANFANG) + 2, 2)
On Error Resume Next
lKWNr = sKWNr
If Err.Number <> 0 Then Err.Clear Else sKW = cBLTNAME_ANFANG & (lKWNr + 1)->KWNr um 1 erhöhen
On Error GoTo 0
End If
End If
BlattnameKWAusVorigerSpalteAbleiten = sKW
End Function
'*******************************************************************************
Private Function ZellenAufLeerPruefen(ws As Worksheet, lSpalte As Long, _
AbzuarbeitenderBereich As String) As Boolean
Dim z As Long, lCntZellen As Long
ZellenAufLeerPruefen = False
->zu beschreibende Zellen auf leer prüfen
lCntZellen = ws.Range(AbzuarbeitenderBereich).Cells.Count
For z = cZ_ERSTEEINTRAGSZEILE To cZ_ERSTEEINTRAGSZEILE + lCntZellen - 1
If Not IsEmpty(ws.Cells(z, lSpalte)) Then
MsgBox _
zu beschreibende Zelle & ws.Cells(z, lSpalte).Address(False, False) & nicht leer!
Exit Function
End If
Next
ZellenAufLeerPruefen = True
End Function
'*******************************************************************************
Private Function SelectionPruefen(lSpalte As Long) As Boolean
SelectionPruefen = False
->Selection 1 Zelle in Zeile 2
If Selection.Count > 1 Then MsgBox Bitte nur eine Zelle selektieren.: Exit Function
If Selection.Row <> 2 Then MsgBox Bitte die Zelle in Zeile 2 selektieren.: Exit Function
->selektierte Spalte
lSpalte = Selection.Column
SelectionPruefen = True
End Function
