Excel-Makro-Frage

Dieses Thema Excel-Makro-Frage im Forum "Windows XP Forum" wurde erstellt von Sordon, 18. Aug. 2006.

Thema: Excel-Makro-Frage Hallo, ich bin auf der Suche nach einer Lösung, mir jede Woche Zeit zu sparen. Und zwar geht es um eine Spalte, in...

  1. Hallo,

    ich bin auf der Suche nach einer Lösung, mir jede Woche Zeit zu sparen. Und zwar geht es um eine Spalte, in der folgender Inhalt drin steht:

    Zeile 2: =KW32!$B$2
    Zeile 3: =KW32!$C$2
    Zeile 4: =KW32!$B$3
    Zeile 5: =KW32!$C$3

    ...usw. Ich hoffe, das ist verständlich.

    Jetzt muss ich jede Woche eine KW weiter gehen, in diesem Falle wäre diese Woche die KW33 dran. Also markiere ich die Spalte, und ziehe sie eine Spalte weiter nach rechts, sodass in der nächsten Spalte exakt die selben Daten drin stehen, wie in der ursprünglichen.

    Ich muss jetzt manuell hingehen, in jeder Zeile aus der 32 eine 33 machen.
    Ich habe bislang keine Möglichkeit gefunden, diese Arbeit mir zu ersparen.

    Was könnte ich da machen?
     
  2. Hallo Sordon,

    ich hab dir ein Makro FormelKWxxBxUndCxInSpalteAbZeile2 zusammengestellt, daß diese Aufgabe erledigt. Das Makro schaut sogar in die Spalte vorher und leitet daraus den neuen in den Formeln zu verwendenden KW-Blattnamen ab.

    Packe das Makro in ein Modul der Arbeitsmappe.

    Anleitung:

    a) betreffende Excel-Datei öffnen
    b) mit Alt+F11 VB-Editor öffnen
    c) im Project-Fenster VBAProject(betreffende Excel-Datei) selektieren
    d) rechte Maustaste-> einfügen Modul
    e) per Copy and Paste diesen Code einfügen
    Dann die Konstanten anpassen (oben im Makro gekennzeichnet)
    f) Speichern (mit Strg+S)
    g) VB-Editor schliessen (mit Alt+Q)

    Aufruf:

    a) Zelle in Zeile 2 der auszufüllenden Spalte selektieren
    b) Extras->Makro->Makros  ( oder Alt+F8)
    c) Doppelklick auf FormelKWxxBxUndCxInSpalteAbZeile2

    Gruß Matjes :)
    Code:
    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
     
  3. Wow, vielen Dank für deine viele Mühe!

    Ich hoffe, heute die Zeit zu finden, mich damit auseinander zu setzen, ansonsten morgen :)


    :edit: sooo, ich kam nun dazu, das Makro einzubauen. Funktioniert alles einwandfrei, ich bin dir unendlich dankbar! :)