Office 2003: Makro

[Hennes]

Hallo zusammen,

was das Aufzeichnen von Makros angeht, befinde ich mich noch in den Kinderschuhen, und bräuchte eure Hilfe.
Über ein Formularsteuerelement möchte ich folgendes Makro aktivieren.

Tabellenblatt 1 zeigt den Tagesverbrauch bestimmter Artikel.
Zelle A2= Datum (Heute())
Zelle A3= Artikelnummer
Zelle B3= Einzelpreis
Zelle C3= Anzahl
Zelle D3= Gesamtpreis

Tabellenblatt 2 soll nun den Monatsverbrauch selbiger Artikel anzeigen
Zelle A3= Artikelnummer
Zelle B3= Einzelpreis
Zelle C2 bis AG2= Datum (vom 1.1. bis 31.1. als Beispiel)
Zelle C3 bis AG3= Anzahl
Zelle AH3= Gesamtpreis

Das Makro soll nun bei Klick auf den Button, die Zelle $A$2 aus Tabellenblatt 1 mit den Zellen B2 bis AF2 vergleichen, und bei Übereinstimmung die Einträge der Spalte C ab Zelle C4 bis Zelle C100 in Tabellenblatt 1 kopieren, in Tabellenblatt 2 unter dem entsprechendem Datum einfügen, und die Werte in Spalte C ab Zelle C4 bis C100 in Tabellenblatt 1 enternen.

Die einzelene Makrofunktion für das Kopieren, Einfügen und Entfernen habe ich ja soweit hinbekommen. Jedoch die vorgehende Wenn-Funktion (Prüfung des Datums) macht mir Probleme.

Ich hoffe, dass mir hier jemand helfen kann.

Danke schonmal im Voraus.

Gruß Hennes

[StefKe]

Hallo Hennes, schau Dir das angehängt Arbeitsblatt an. Die Prüfung erfolgt in einer For-Next-Schleife. Hier der Code:

Code: [Auswählen]

Option Explicit

Sub SummeBilden()
    Dim datAnfDatum As Date
    Dim datEndDatum As Date
    Dim lngZeilennr As Long
    Dim i
    Dim e
    Dim curWert As Currency

    datAnfDatum = ActiveSheet.Range("A2").Value
    datEndDatum = ActiveSheet.Range("B2").Value
   
    lngZeilennr = Columns(3).Find(What:=datAnfDatum, After:=ActiveSheet.Cells(1, 3), LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Row
       
    e = datEndDatum - datAnfDatum + lngZeilennr
       
    For i = lngZeilennr To e
        'Cells(i, 3).Select
        curWert = ActiveSheet.Cells(i, 4).Value + curWert
    Next i
       
    ActiveSheet.Range("E2") = curWert
End Sub



[Hennes]

Hallo StefKe,
erstmal vielen Dank für deine Bemühungen, aber leider entspricht das nicht so ganz meinen Vorstellungen.
Ich dachte eher an eine einfache Wenn-Funktion, wie Zb
Zelle C4 in Tabelle2: =wenn(Tabelle2!C2=Tabelle1!$A$2;"starte Markro Strg+x";"")
diese Formel dann von C4 bis AG4 in Tabelle2 kopieren, das Ganze als Makro aufzeichenen und dann dem Button zuweisen.
NUR... der Teil in der Formel, also das DANN, will nicht funktionieren.

Gruß Hennes

[Hennes]

Hallo zusammen,

ich versuch´s einfach nochmal. Vielleicht ist es auch anschaulicher in der angehängten Datei.

Gruß Hennes

[StefKe]

Hallo Hennes, die Ausführung eines Makros in eine Formel einzubinden ist mir nicht bekannt. Einfacher wäre es per Code:

• Das Datum aus "Tagesverbrauch"C2 mit "Gesamtverbrauch"C1:Q1" zu vergleichen.
• Ist das Datum bereits vorhanden werden die Werte zu entsprechenden Spalte dazuaddiert.
• Ist das Datum noch nicht vorhanden wird eine neue Spalte mit den Werten eingefügt.
• Als Letztes werden die Werte im Blatt "Tagesverbrauch" C5:C24 gelöscht.

Das Makro wird über eine Schaltfläche gestartet, welche sich auch in die Menueleiste einbinden lässt. Oder Du bastelst ein Userform.
Wenn das so passt können wir es Schritt für Schritt machen.

Stefan

[Hennes]

Hallo Stefan,
das klingt super.
So machen wir´s.

Danke schonmal.
Liesse sich denn das Makro auch über meinen "Neu" Button starten???

Gruß Hennes

[StefKe]

Hallo Hennes, das Makro kann über den "Neu"-Button gestartet werden.
2 Fragen: ist die Anzahl der Bauteile (20) fest, oder variabel. Und ist die Anzahl der Tage in "Gesamtverbrauch" Zeile 1 immer gleich oder variabel?

Gruß
Stefan

[Hennes]

Hallo Stefan,
also die Anzahl der Bauteile ist fest. In der Originaldatei sind es jedoch 100 Bauteile. Ich hatte mir gedacht, dass ich das Makro dann entsprechend meiner Originaldatei anpassen kann.
Die Anzahl der Tage ist ebenfalls fest. Vom 01.01.17 bis 31.12.17...

Was mir grad noch einfällt.
Vielleicht wäre es sinnvoller, wenn man direkt die Spalte "Anzahl" und die Spalte "Gesamtpreis" nach Jahresverbrauch kopiert, da ich vorhaben, dann über Jahresverbrauch eine Pivottabelle zu erstellen. Somit erübrigt sich dann auch die Spalte "Gesamtsumme" im Jahresverbrauch. Das macht ja die Pivot von allein.

Gruß Hennes

[StefKe]

Hallo Hennes, hier die Arbeitsmappe zurück. Vielleicht denkst Du über den Aufbau der Tabelle "Gesamtverbrauch" noch mal nach. Da diese Tabelle später mit einem Pivot-Table ausgewertet werden soll sind die Formatierungen und Verbindungen der Zellen eher nachteilig. Du solltest Dich auch dafür entscheiden die Datumsangaben in eine Spalte zu schreiben.

Hier der Code:

Code: [Auswählen]

Sub Werte_uebertragen()
Dim dtDatum As Date
Dim wksTagesverbrauch As Worksheet
Dim wksGesamtverbrauch As Worksheet
Dim rngSuchbereich As Range
Dim rngDatumZelle As Range
Dim lngDatumReihe As Long
Dim arrWerte(19)
Dim i

        Set wksTagesverbrauch = Worksheets("Tagesverbrauch")
        Set wksGesamtverbrauch = Worksheets("Gesamtverbrauch")
        Set rngSuchbereich = wksGesamtverbrauch.Range("C1:P1")
       
    'falls das Datum noch nicht existiert wir eine neue Spalte eingefügt und beschriftet:
        dtDatum = wksTagesverbrauch.Cells(2, 3)
        Set rngDatumZelle = rngSuchbereich.Find(What:=dtDatum, After:=ActiveSheet.Cells(1, 3), LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
               
        If rngDatumZelle Is Nothing Then
            lngDatumReihe = WorksheetFunction.Count(wksGesamtverbrauch.Rows(1)) + 3
            With wksGesamtverbrauch
                .Activate
                .Columns(lngDatumReihe).EntireColumn.Insert
                .Range(Cells(1, lngDatumReihe), Cells(3, lngDatumReihe)).Merge
                .Cells(1, lngDatumReihe) = dtDatum
            End With
        Else
            lngDatumReihe = rngDatumZelle.Column
        End If
   
    'Die Werte vom Blatt "Tagesverbrauch" werden in ein Array geschrieben:
    With wksTagesverbrauch
        For i = 0 To 19
           arrWerte(i) = .Cells(i + 5, 3).Value
        Next i
       
        .Range("C5:C24").ClearContents
    End With
   
    'Die Werte aus dem Array werden in die neue Spalte übertragen:
    With wksGesamtverbrauch
         For i = 0 To 19
            .Cells(i + 5, lngDatumReihe) = arrWerte(i)
            .Cells(i + 5, lngDatumReihe + 1).FormulaR1C1 = "=SUM(Gesamtverbrauch!RC3:RC" & lngDatumReihe & ")"
         Next i
    End With
End Sub


[Hennes]

Hallo Stefan,

genial!!! TOP!!!
läuft.... auch in meiner Originaldatei...
habe mich auch dazu entschieden, keine Pivot drüber zu legen.
Ist so vollkommen ausreichend.
(erstmal... ;-)  )

vielen, vielen Dank kann ich da nur sagen.

eine Frage noch...
wie würde solch ein Makro aussehen, wenn ich einen variablen Zellbereich
zB A3 bis Kxx von Tabellenblatt1 zu Tabellenblatt2 übertragen möchte, die
Einträge aus dem selben Zellbereich im Anschluss entfernen möchte, und die Einträge im
Tabellenblatt2 ab Zelle A2 fortlaufend sein sollen. Also jeder neue Übertrag soll
in die nächste freie Zeile erfolgen.

Gruß Hennes

[StefKe]

Hi Hennes, Du musst die Größe des Datenfeldes (Zeilen,Spalten) ermitteln und das Array entsprechend anpassen. Arrays werden hier recht gut geklärt:
http://www.vba-wordwelt.de/grundsaetzliches/wichtige-funktionen/array/

Eine andere Möglichkeit wäre das Datenfeld mit 2 Schleifen zu durchlaufen und so Zelle für Zelle zu kopieren.
Mit dem Code:" .Range("XX:DD").ClearContents " wird der Bereich im Tabellenblatt1 gelöscht.

[Hennes]

Hallo Stefan,

Das Schreiben eines Code ist für mich ein unlösbares Problem.
Ich schaffe es wohl, ein Makro aufzuzeichnen, was mir die gewünschte Aktion ausführt.
Aber das ganze funktioniert immer nur ein mal, weil dann beim Einfügen immer wieder
alles überschrieben wird. Nur das ist ja nicht Sinn und Zweck des Ganzen.
Wäre super, wenn du mir nochmals helfen könntest.
Ich würde das Datenfeld festlegen auf B3:K35.
Gruß Hennes

[StefKe]

o.k., dann baue bitte eine Tabelle so zusammen wie sie am Ende aussehen soll und wir erstellen dann den Code.

Stefan

[Hennes]

Supi... Danke 

Spalte A in Tagesbuchungen wird automatisch durch einen Code bei jedem neuen Eintrag gefüllt.
Übertragen werden soll dann der Bereich A3:K35 oder nur die gefüllten Zeilen in diesem Bereich, wobei die
Spalte "Bemerkungen" nicht immer gefüllt ist, jenachdem was einfacher geht.
Jeder neue Übertrag soll dann in die nächste leere Zeile in "Jahresübersicht" erfolgen.

[StefKe]

Hallo Hennes, mit dem Code:

Code: [Auswählen]

Sub Werte_Uebertragen()
Dim wksTag As Worksheet
Dim wksJahr As Worksheet
Dim lngZeileTag As Long
Dim lngZeileJahr As Long
Dim rngWerteJahr As Range
Dim i As Long
Dim x As Long
Dim arrWert()

Set wksTag = Worksheets("Tagesbuchungen")
Set wksJahr = Worksheets("Jahresübersicht")
lngZeileTag = WorksheetFunction.Count(wksTag.Range("A3:A35"))
If lngZeile = 0 Then Exit Sub
ReDim arrWert(lngZeileTag - 1, 10)

'alle Zellen wo in Spalte A ein Datum steht werden in das Array übertragen:
For i = 0 To lngZeileTag - 1
    For x = 0 To 10
        arrWert(i, x) = wksTag.Cells(i + 3, x + 1)
    Next x
Next i
'alle Daten in Tabelle Tagesbuchungen werden gelöscht:
wksTag.Range("A3:K" & lngZeileTag + 2).ClearContents

'alle Werte in Tabellenblatt "Jahresübersicht" eintragen:
lngZeileJahr = WorksheetFunction.Count(wksJahr.Range("A:A"))
wksJahr.Activate
Set rngWerteJahr = wksJahr.Range(Cells(lngZeileJahr + 3, 1), Cells(lngZeileJahr + lngZeileTag + 2, 11))
For i = 0 To lngZeileTag - 1
    For x = 0 To 10
        rngWerteJahr.Cells(i + 1, x + 1) = arrWert(i, x)
    Next x
Next i
End Sub

werden alle ausgefüllten Zeilen vom Tabellenblatt "Tagesbuchungen" in ein Array übertragen, dann wird der Bereich gelöscht und das Array in der Jahresübersicht unten angefügt. Du brauchst nur eine Möglichkeit den Code zu starten.

Soweit, sogut... mangels meiner VBA-Kenntnisse erschließt sich mir nicht der Sinn des im Tabellblatt "Tagesbuchungen" hinterlegt Code:

Code: [Auswählen]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim wert_old As String
Dim wertnew As String
On Error GoTo Errorhandling
If Not Application.Intersect(Target, Range("J3:J7300")) Is Nothing Then
  Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
  If rngDV Is Nothing Then GoTo Errorhandling
    If Not Application.Intersect(Target, rngDV) Is Nothing Then
    Application.EnableEvents = False
    wertnew = Target.Value
    Application.Undo
    wertold = Target.Value
    Target.Value = wertnew
    If wertold <> "" Then
      If wertnew <> "" Then
        Target.Value = wertold & ", " & wertnew
      End If
    End If
  End If

End If

Errorhandling:
Application.EnableEvents = True

   If Target.Column <> 2 Then Exit Sub
   If Target = "" Then
      Target.Offset(0, -1) = ""
   Else
      Target.Offset(0, -1) = Date
End If

End Sub

Stefan

[Hennes]

Hallo Stefan,
dieser Code sorgt lediglich dafür, dass bei jedem Eintrag in Spalte B automatisch das
Datum in Spalte A eingetragen wird.

Leider tut sich bei deinem Code bei mir nichts.
Kannst du noch mal drüber schauen???

Guß Hennes

[StefKe]

Das aktuelle Datum lässt sich einfach mit der Tastenkombination Strg + Punkt eingeben.
Ein x-beliebiges Datum: 24-1 eingeben - wird von Exel in 24.01.2017 umgewandelt, je nach definiertem Zellformat.

Habe den Code im Tabellenblatt gelöscht und einen Button angelegt, welcher mein Makro startet.
Passt so?

[Hennes]

Supi, jetzt geht´s... !!!

Jetzt hab ich nur noch ein klitzekleines Problem.
In den Spalten C bis H sind Formeln hinterlegt (SVerweis).
Diese Zellen können natürlich überschrieben werden, wenn der angezeigte Wert nicht passt.
Alle Formeln habe ich in ein Makro geschrieben, damit ich sie bei Bedarf wieder eintragen lassen kann.
Nun werden ja beim Übertragen der Werte meine Formeln gelöscht.
Kann man durch einen Befehl am Ende deines Codes mein Makro "Autofüllen" direkt ausführen lassen?

[StefKe]

Ja sicherlich, stell das Makro hier ein...oder besser die Tabelle mit den Formel dazu....

[Hennes]

hier einmal das Makro, welches im Tabellenblatt "Tagesbuchungen" laufen soll...

beides einzeln, also dein Code und mein Makro, funktioniert...

Code: [Auswählen]

Sub Autofüllen()
'
' Autofüllen Makro
' Formeln eintragen
'
' Tastenkombination: Strg+y
'
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[1]="""","""",TODAY())"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[1]="""","""",TODAY())"
    Range("A4").Select
    Selection.AutoFill Destination:=Range("A4:A34"), Type:=xlFillDefault
    Range("A4:A34").Select
    Range("A35").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[1]="""","""",TODAY())"
    Range("C3").Select
        ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(ISNA(MATCH(RC[-1],Abos!R3C2:R50C2,0)),""ohne Vertrag"",""mit Vertrag""))"
    Range("C4").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(ISNA(MATCH(RC[-1],Abos!R3C2:R50C2,0)),""ohne Vertrag"",""mit Vertrag""))"
    Range("C4").Select
    Selection.AutoFill Destination:=Range("C4:C34"), Type:=xlFillDefault
    Range("C4:C34").Select
    Range("C35").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]="""","""",IF(ISNA(MATCH(RC[-1],Abos!R3C2:R50C2,0)),""ohne Vertrag"",""mit Vertrag""))"
    Range("D3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-2]="""","""",IF(RC[-1]=""ohne Vertrag"","""",VLOOKUP(RC[-2],Abos!R3C2:R50C7,2,FALSE)))"
    Range("D4").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-2]="""","""",IF(RC[-1]=""ohne Vertrag"","""",VLOOKUP(RC[-2],Abos!R3C2:R50C7,2,FALSE)))"
    Range("D4").Select
    Selection.AutoFill Destination:=Range("D4:D34"), Type:=xlFillDefault
    Range("D4:D34").Select
    Range("D35").Select
    Selection.ClearContents
    Range("E8:H21").Select
    Selection.ClearContents
    Range("D35").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-2]="""","""",IF(RC[-1]=""ohne Vertrag"","""",VLOOKUP(RC[-2],Abos!R3C2:R50C7,2,FALSE)))"
    Range("E3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-3]="""","""",IF(RC[-2]=""ohne Vertrag"","""",VLOOKUP(RC[-3],Abos!R3C2:R50C7,3,FALSE)))"
    Range("E4").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-3]="""","""",IF(RC[-2]=""ohne Vertrag"","""",VLOOKUP(RC[-3],Abos!R3C2:R50C7,3,FALSE)))"
    Range("E4").Select
    Selection.AutoFill Destination:=Range("E4:E34"), Type:=xlFillDefault
    Range("E4:E34").Select
    Range("E35").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-3]="""","""",IF(RC[-2]=""ohne Vertrag"","""",VLOOKUP(RC[-3],Abos!R3C2:R50C7,3,FALSE)))"
    Range("F3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-4]="""","""",IF(RC[-3]=""ohne Vertrag"","""",VLOOKUP(RC[-4],Abos!R3C2:R50C7,4,FALSE)))"
    Range("F4").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-4]="""","""",IF(RC[-3]=""ohne Vertrag"","""",VLOOKUP(RC[-4],Abos!R3C2:R50C7,4,FALSE)))"
    Range("F4").Select
    Selection.AutoFill Destination:=Range("F4:F34"), Type:=xlFillDefault
    Range("F4:F34").Select
    Range("F35").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-4]="""","""",IF(RC[-3]=""ohne Vertrag"","""",VLOOKUP(RC[-4],Abos!R3C2:R50C7,4,FALSE)))"
    Range("G3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-5]="""","""",IF(RC[-4]=""ohne Vertrag"","""",VLOOKUP(RC[-5],Abos!R3C2:R50C7,5,FALSE)))"
    Range("G4").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-5]="""","""",IF(RC[-4]=""ohne Vertrag"","""",VLOOKUP(RC[-5],Abos!R3C2:R50C7,5,FALSE)))"
    Range("G4").Select
    Selection.AutoFill Destination:=Range("G4:G34"), Type:=xlFillDefault
    Range("G4:G34").Select
    Range("G35").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-5]="""","""",IF(RC[-4]=""ohne Vertrag"","""",VLOOKUP(RC[-5],Abos!R3C2:R50C7,5,FALSE)))"
    Range("H3").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-6]="""","""",IF(RC[-5]=""ohne Vertrag"","""",VLOOKUP(RC[-6],Abos!R3C2:R50C7,6,FALSE)))"
    Range("H4").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-6]="""","""",IF(RC[-5]=""ohne Vertrag"","""",VLOOKUP(RC[-6],Abos!R3C2:R50C7,6,FALSE)))"
    Range("H4").Select
    Selection.AutoFill Destination:=Range("H4:H34"), Type:=xlFillDefault
    Range("H4:H34").Select
    Range("H35").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-6]="""","""",IF(RC[-5]=""ohne Vertrag"","""",VLOOKUP(RC[-6],Abos!R3C2:R50C7,6,FALSE)))"
    Range("H35").Select
End Sub


[StefKe]

Hallo Hennes, die gelöschten Bereiche werden jetzt wieder mit den Formeln aufgefüllt.

[Hennes]

Supi... Danke schön...

Hatte zwischenzeitlich auch noch eine Lösung gefunden.
Habe das Makro mit auf den CommandButton gelegt.

Also, vielen Dank nochmal für deine Mühe.
Einfach TOP!!