VBA Makro per button ausführen

Question

Hallo zusammen,

Ich habe einen Button erstellt und diesem ein Makro zugewiesen, welches bei dem Wert „Ja“ neue Zeilen einfügt und diese Formatiert. Dies läuft auch einwandfrei. Wenn ich aber erneut auf den Button klicke, fügt das Makro die gleichen Zeilen erneut ein. Ich möchte aber, dass jede Zeile in der ein „Ja“ vorkommt nur einmal auf der neu generierten liste erscheint. D.h. beim 2. Klicken auf den Button soll die generierte Liste quasi nur noch aktualisiert werden. Dasselbe gilt wenn man ein „ja“ wieder entfernt, soll es aus der bereits generierten Liste wieder verschwinden.
Ich hoff ihr könnt mir helfen!

Hier mein Makro:

Sub Makro3()
Dim rCell As Range
Dim rRng As Range
Dim lzeile As Long
Set rRng = Worksheets("Verkaufsgruppen").Range("D3:D215")

'Zellen im Bereich nach Ja durchsuchen
For Each rCell In rRng.Cells

'Prüfen ob Zellinhalt Ja ist
If rCell.Value = "Ja" Then

'falls ja, dann
With Sheets("Giesserei")
.Range("A5:A7").EntireRow.Insert 'Zeilen einfügen
.Cells(5, 2) = "VOK" 'Text einfügen
.Cells(6, 2) = "BEMI"
.Cells(7, 2) = "Invest"

With .Range("A5:A7") 'Spalte A formatieren
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.ReadingOrder = xlContext
.MergeCells = True
End With

'Name aus dem Blatt Verkaufsgruppen einfügen
.Range("A5") = Worksheets("Verkaufsgruppen").Cells(rCell.Row, 2)

End With

End If

Next rCell

'letzte beschriebene Zeile in Spalte B ermitteln für Summen
lzeile = Sheets("Giesserei").Cells(Rows.Count, 2).End(xlUp).Row

'Summewenn-Formeln einfügen; letzte Zeilen in Tabelle Giesserei
With Sheets("Giesserei")
.Cells(lzeile + 1, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";C5:C" & lzeile & ")"
.Cells(lzeile + 2, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";C5:C" & lzeile & ")"
.Cells(lzeile + 3, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";C5:C" & lzeile & ")"
End With

End Sub

Mit freundlichen grüßen peyd

Answer 1

Hallo peyd,

das ist richtig, da ja mit der Zeile

.Range("A5:A8").EntireRow.Insert 'Zeilen einfügen

neue Zeilen eingefügt werden, alles also nach unten rutscht.

Da das Einfügen der Zeilen eigentlich überflüssig ist, habe ich den Code so geändert, dass dein Text nicht mehr unten geschoben wird:
[code]Sub Makro_Giesserei()

Dim rCell As Range
Dim rRng As Range
Dim lzeile As Long
Dim ArrayC() As Variant
Dim zeile As Long
Dim i As Long
Dim j As Long
Dim pruef As Boolean
Dim z As Long
Dim s As Long


'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Anzahl der Datensätze in Tabelle Giesserei ermitteln
lzeile = Sheets("Giesserei").Cells(Rows.Count, 2).End(xlUp).Row

'prüfen, ob letzte Zeile größer 4

If lzeile < 5 Then
pruef = False
Else
pruef = True
End If

If pruef = True Then
'Feld neu dimensionieren
ReDim ArrayC(lzeile - 4, 7)

'Daten aus Tabelle Giesserei, Spalte C in das Feld einlesen

For zeile = 5 To lzeile Step 4 ' ab Zeile 5 alle 4 Zeilen wiederholen


ArrayC(zeile - 4, 0) = Worksheets("Giesserei").Cells(zeile, 1).Value 'Name in Array schreiben

For z = 0 To 3
For s = 1 To 7
ArrayC(zeile - 4 + z, s) = Worksheets("Giesserei").Cells(zeile + z, 2 + s).Value 'Werte der Spalten C bis I in Array schreiben
Next s
Next z

Next zeile

'Nun Inhalt des Blattes Giesserei löschen
lzeile = Worksheets("Giesserei").Cells(Rows.Count, 3).End(xlUp).Row
With Worksheets("Giesserei")
.Range(.Cells(5, 1), .Cells(lzeile, 11)).MergeCells = False
.Range(.Cells(5, 1), .Cells(lzeile, 11)).ClearContents
End With

End If

'Tabellenblatt Giesserei neu aufbauen
Set rRng = Worksheets("Verkaufsgruppen").Range("D3:D215")

'Zeile zum Einfügen setzen
zeile = 5

'Zellen im Bereich nach Ja durchsuchen
For Each rCell In rRng.Cells

'Prüfen ob Zellinhalt Ja ist
If rCell.Value = "Ja" Then

'falls ja, dann
With Sheets("Giesserei")
.Cells(zeile, 2) = "Anlaufkosten"
.Cells(zeile + 1, 2) = "VOK" 'Text einfügen
.Cells(zeile + 2, 2) = "BEMI"
.Cells(zeile + 3, 2) = "Invest"
.Cells(zeile, 10) = "=SUM(RC[-7]:RC[-1])" 'Zeilensummen Spalte J bilden
.Cells(zeile + 1, 10) = "=SUM(RC[-7]:RC[-1])"
.Cells(zeile + 2, 10) = "=SUM(RC[-7]:RC[-1])"
.Cells(zeile + 3, 10) = "=SUM(RC[-7]:RC[-1])"

With .Range(.Cells(zeile, 1), .Cells(zeile + 3, 1)) 'Spalte A formatieren
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.ReadingOrder = xlContext
.MergeCells = True
End With

'Name aus dem Blatt Verkaufsgruppen einfügen
.Cells(zeile, 1) = Worksheets("Verkaufsgruppen").Cells(rCell.Row, 2)

End With

'Zeilenzähler zum Einfügen der Zeilen erhöhen
zeile = zeile + 4
End If

Next rCell

'letzte beschriebene Zeile in Spalte B ermitteln
lzeile = Worksheets("Giesserei").Cells(Rows.Count, 2).End(xlUp).Row


'Vorhandene Daten ggf. wieder in Tabelle Giesserei schreiben

If pruef = True Then

zeile = 5

For j = 1 To lzeile Step 4

For i = 1 To UBound(ArrayC) Step 4

If Worksheets("Giesserei").Cells(zeile, 1).Value = ArrayC(i, 0) Then


For z = 0 To 3
For s = 1 To 7
Worksheets("Giesserei").Cells(zeile + z, 2 + s) = ArrayC(i + z, s) 'Werte der Spalten C bis I aus Array in Tabelle schreiben
Next s
Next z


End If

Next i

zeile = zeile + 4

Next j

End If

'Summewenn-Formeln einfügen; letzte Zeilen in Tabelle Giesserei
With Sheets("Giesserei")
.Cells(lzeile + 1, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";C5:C" & lzeile & ")"
.Cells(lzeile + 2, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";C5:C" & lzeile & ")"
.Cells(lzeile + 3, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";C5:C" & lzeile & ")"
.Cells(lzeile + 4, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";C5:C" & lzeile & ")"

.Cells(lzeile + 1, 4).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";D5:D" & lzeile & ")"
.Cells(lzeile + 2, 4).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";D5:D" & lzeile & ")"
.Cells(lzeile + 3, 4).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";D5:D" & lzeile & ")"
.Cells(lzeile + 4, 4).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";D5:D" & lzeile & ")"

.Cells(lzeile + 1, 5).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";E5:E" & lzeile & ")"
.Cells(lzeile + 2, 5).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";E5:E" & lzeile & ")"
.Cells(lzeile + 3, 5).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";E5:E" & lzeile & ")"
.Cells(lzeile + 4, 5).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";E5:E" & lzeile & ")"

.Cells(lzeile + 1, 6).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";F5:F" & lzeile & ")"
.Cells(lzeile + 2, 6).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";F5:F" & lzeile & ")"
.Cells(lzeile + 3, 6).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";F5:F" & lzeile & ")"
.Cells(lzeile + 4, 6).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";F5:F" & lzeile & ")"

.Cells(lzeile + 1, 7).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";G5:G" & lzeile & ")"
.Cells(lzeile + 2, 7).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";G5:G" & lzeile & ")"
.Cells(lzeile + 3, 7).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";G5:G" & lzeile & ")"
.Cells(lzeile + 4, 7).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";G5:G" & lzeile & ")"

.Cells(lzeile + 1, 8).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";H5:H" & lzeile & ")"
.Cells(lzeile + 2, 8).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile

Answer 2

Was mir gerade eingefallen ist:: das Makro muss ja die kompletten Zeilen löschen, sonst funktioniert der neuaufbau der Tabelle nicht, deswegen fügt er auch die neuen Zeilen ein.

Gibt es vielleicht eine andere möglichkeit wie man die Daten vor dem Löschen schützen könnte? Mein Ansatz wäre gewesen Sie einfach mit in den Array aufzunehmen, allerdings handelt es sich um eine Spalte mit Text und eine Spalte mit Formeln. Die Formeln werden aber leider beim Neuaufbau bzw. einfügen des Arrays nicht mit übernommen :( Gibt es da eine möglichkeit?

vielen Dank schonmal!

LG peyd

Answer 3

Hallo M.O.,

vielen Dank für den Ansatz! Er funktioniert auch, aber wie ich schon oben geschrieben habe, funktioniert dann das Löschen nicht mehr. Also wenn ich dann im Blatt Verkaufsgruppen ein "JA" entferne löscht er die Zeilen nicht mehr :/
Könnte man das über den Array (s.o.) lösen?

LG peyd

Answer 4

Hallo peyd,

du hattest in deiner Antwort 18 geschrieben:

kann man beim Löschen der Zelleninhalte den Bereich begrenzen?

Das habe ich so verstanden, dass die Spalten A - K gelöscht werden sollen, der Rest aber erhalten bleiben soll (weil dort allgemeine Daten stehen, nicht auf die jeweilige Zeile bezogen).

In Spalte J fügst du ja über das funktionierende Makro Formeln ein. Welche Spalte(n) sollen denn jetzt noch zusätzlich erhalten bleiben?

.. allerdings handelt es sich um eine Spalte mit Text und eine Spalte mit Formeln

Den Text kann man erhalten. Sind die Formeln immer gleich, dann kann man diese auch per Makro einfügen.

Du müsstest schon etwas genauer erläutern, was geändert werden soll.

Gruß

M.O.

Answer 5

Hallo M.O.,

Das das Löschen des Bereiches nicht so gehen kann wie ich es mir dachte ist mir leider erst nach deinem Ansatz bewusst geworden - sorry dafür.

Also ich habe jetzt in Spalte J Summen-Formeln und in den Spalten K & L möchte ich Anmerkungen zu den jewiligen Zeilen manuell eintragen. Das Makro löscht aber diese manuellen Einträge beim ausführen. Deshalb der wunsch nur den Bereich bis Spalte K zu löschen, was jedoch den wiederaufbau der Tabelle nicht mehr ermöglicht.

In dem Makro werden die Spalten C - I in den Array geschrieben. Mein Ansatz war es, einfach die Spalten C- L in den Array zu schreiben also :
'Feld neu dimensionieren
ReDim ArrayC(lzeile - 4, 10)

um somit das Löschen der manuellen Anmerkungen zu verhindern.

Das klappt auch soweit, aber dann Übernimmt das Makro nicht die Summenformeln von Spalte J sondern nur noch den Wert der angezeigt wurde.

Hoffe das war jetzt verständlicher -.-
LG peyd

Answer 6

Hallo peyd,

schau mal, ob das Makro jetzt so funktioniert, wie du es willst.

[code]Sub Makro_Giesserei2()

Dim rCell As Range
Dim rRng As Range
Dim lzeile As Long
Dim ArrayC() As Variant
Dim zeile As Long
Dim i As Long
Dim j As Long
Dim pruef As Boolean
Dim z As Long
Dim s As Long


'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Anzahl der Datensätze in Tabelle Giesserei ermitteln
lzeile = Sheets("Giesserei").Cells(Rows.Count, 2).End(xlUp).Row

'prüfen, ob letzte Zeile größer 4

If lzeile < 5 Then
pruef = False
Else
pruef = True
End If

If pruef = True Then
'Feld neu dimensionieren
ReDim ArrayC(lzeile - 4, 9)

'Daten aus Tabelle Giesserei, Spalte C in das Feld einlesen

For zeile = 5 To lzeile Step 4 ' ab Zeile 5 alle 4 Zeilen wiederholen


ArrayC(zeile - 4, 0) = Worksheets("Giesserei").Cells(zeile, 1).Value 'Name in Array schreiben

For z = 0 To 3
For s = 1 To 7
ArrayC(zeile - 4 + z, s) = Worksheets("Giesserei").Cells(zeile + z, 2 + s).Value 'Werte der Spalten C bis I in Array schreiben
Next s
'Spalte K in Array schreiben; falls dort eine Formel enthalten ist, wird die Formel ins Array geschrieben
If Worksheets("Giesserei").Cells(zeile + z, 11).HasFormula = True Then
ArrayC(zeile - 4 + z, 8) = Worksheets("Giesserei").Cells(zeile + z, 11).Formula
Else
ArrayC(zeile - 4 + z, 8) = Worksheets("Giesserei").Cells(zeile + z, 11).Value
End If

'und das Selbe mit Spalte L
If Worksheets("Giesserei").Cells(zeile + z, 12).HasFormula = True Then
ArrayC(zeile - 4 + z, 9) = Worksheets("Giesserei").Cells(zeile + z, 12).Formula
Else
ArrayC(zeile - 4 + z, 9) = Worksheets("Giesserei").Cells(zeile + z, 12).Value
End If

Next z

Next zeile

'Nun Inhalt des Blattes Giesserei löschen
lzeile = Worksheets("Giesserei").UsedRange.SpecialCells(xlCellTypeLastCell).Row
With Worksheets("Giesserei")
.Range(.Cells(5, 1), .Cells(lzeile, 1)).EntireRow.Delete
End With

End If

'Tabellenblatt Giesserei neu aufbauen
Set rRng = Worksheets("Verkaufsgruppen").Range("D3:D215")

'Zeile zum Einfügen setzen
zeile = 5

'Zellen im Bereich nach Ja durchsuchen
For Each rCell In rRng.Cells

'Prüfen ob Zellinhalt Ja ist
If rCell.Value = "Ja" Then

'falls ja, dann
With Sheets("Giesserei")
.Cells(zeile, 2) = "Anlaufkosten"
.Cells(zeile + 1, 2) = "VOK" 'Text einfügen
.Cells(zeile + 2, 2) = "BEMI"
.Cells(zeile + 3, 2) = "Invest"
.Cells(zeile, 10).FormulaR1C1 = "=SUM(RC[-7]:RC[-1])" 'Zeilensummen Spalte J bilden
.Cells(zeile + 1, 10).FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"
.Cells(zeile + 2, 10).FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"
.Cells(zeile + 3, 10).FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"

With .Range(.Cells(zeile, 1), .Cells(zeile + 3, 1)) 'Spalte A formatieren
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.ReadingOrder = xlContext
.MergeCells = True
End With

'Name aus dem Blatt Verkaufsgruppen einfügen
.Cells(zeile, 1) = Worksheets("Verkaufsgruppen").Cells(rCell.Row, 2)

End With

'Zeilenzähler zum Einfügen der Zeilen erhöhen
zeile = zeile + 4
End If

Next rCell

'letzte beschriebene Zeile in Spalte B ermitteln
lzeile = Worksheets("Giesserei").Cells(Rows.Count, 2).End(xlUp).Row


'Vorhandene Daten ggf. wieder in Tabelle Giesserei schreiben

If pruef = True Then

zeile = 5

For j = 1 To lzeile Step 4

For i = 1 To UBound(ArrayC) Step 4

If Worksheets("Giesserei").Cells(zeile, 1).Value = ArrayC(i, 0) Then


For z = 0 To 3
For s = 1 To 7
Worksheets("Giesserei").Cells(zeile + z, 2 + s) = ArrayC(i + z, s) 'Werte der Spalten C bis I aus Array in Tabelle schreiben
Next s
'Spalten K und L aus Array in Tabelle schreiben
Worksheets("Giesserei").Cells(zeile + z, 11) = ArrayC(i + z, 8)
Worksheets("Giesserei").Cells(zeile + z, 12) = ArrayC(i + z, 9)

Next z


End If

Next i

zeile = zeile + 4

Next j

End If

'Summewenn-Formeln einfügen; letzte Zeilen in Tabelle Giesserei
With Sheets("Giesserei")
.Cells(lzeile + 1, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";C5:C" & lzeile & ")"
.Cells(lzeile + 2, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";C5:C" & lzeile & ")"
.Cells(lzeile + 3, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";C5:C" & lzeile & ")"
.Cells(lzeile + 4, 3).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";C5:C" & lzeile & ")"

.Cells(lzeile + 1, 4).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";D5:D" & lzeile & ")"
.Cells(lzeile + 2, 4).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";D5:D" & lzeile & ")"
.Cells(lzeile + 3, 4).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";D5:D" & lzeile & ")"
.Cells(lzeile + 4, 4).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";D5:D" & lzeile & ")"

.Cells(lzeile + 1, 5).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";E5:E" & lzeile & ")"
.Cells(lzeile + 2, 5).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";E5:E" & lzeile & ")"
.Cells(lzeile + 3, 5).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";E5:E" & lzeile & ")"
.Cells(lzeile + 4, 5).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";E5:E" & lzeile & ")"

.Cells(lzeile + 1, 6).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";F5:F" & lzeile & ")"
.Cells(lzeile + 2, 6).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""VOK"";F5:F" & lzeile & ")"
.Cells(lzeile + 3, 6).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""BEMI"";F5:F" & lzeile & ")"
.Cells(lzeile + 4, 6).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Invest"";F5:F" & lzeile & ")"

.Cells(lzeile + 1, 7).FormulaLocal = "=SUMMEWENN(B5:B" & lzeile & ";""Anlaufkosten"";G5:G" & lzeile & ")"
.Cells(lzeile + 2, 7).FormulaLocal = "=SUMMEWENN(B5:B&quot

Answer 7

Hallo M.O.,

genau so hab ich mir das vorgestellt mit dem Array ;-) Super umgesetzt, vielen vielen Dank!
Allerdings setzt das Makro nun ab Zeile 4 alle Formatierungen von den Zellen zurück, also Größen, Farben, Schrift werden auf Standart gesetzt. Woher könnte das kommen?

LG peyd

Answer 8

Hallo Peyd,

da die Zeilen gelöscht werden, verschwinden natürlich auch die Formatierungen (das sollte im ursprünglichen Makro aus Antwort 14 aber auch schon so gewesen sein)

Du kannst den Codeteil:

'Nun Inhalt des Blattes Giesserei löschen
lzeile = Worksheets("Giesserei").UsedRange.SpecialCells(xlCellTypeLastCell).Row
With Worksheets("Giesserei")
.Range(.Cells(5, 1), .Cells(lzeile, 1)).EntireRow.Delete
End With

durch

'Nun Inhalt des Blattes Giesserei löschen
lzeile = Worksheets("Giesserei").UsedRange.SpecialCells(xlCellTypeLastCell).Row
With Worksheets("Giesserei")
.Range(.Cells(5, 1), .Cells(lzeile, 12)).MergeCells = False
.Range(.Cells(5, 1), .Cells(lzeile, 12)).ClearContents
End With

ersetzen, dann wird die Formatierung, soweit vorhanden nicht gelöscht.

Ich hatte noch einen Hinweis vergessen:
Da in Spalte K und L ggf. auch Formeln in das Array eingelesen werden und diese mit den eingelesenen Bezügen wieder zurückgeschrieben werden, stimmen die Bezüge nach dem Neuaufbau ggf. nicht mehr!

Gruß

M.O.

Answer 9

Hallo M.O.,

SUPER! Jetzt passt alles! Vielen Dank :-)

LG peyd