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,

du solltest auf den Ausgangsthread verweisen: KLICK

Was du auch nicht schreibst, ist dass in die generierte Liste Daten per Hand eingetragen werden, so dass ein Löschen der Liste und ein Neuaufbau ausscheiden.

Können die Namen in der Liste Verkaufsgruppen mehrfach vorkommen? Falls ja, gibt es ein anderes eindeutiges Merkmal, mit dem man die Datensätze zuordnen kann. Werden in der Tabelle Verkaufsgruppen neue Datensätze immer nur am Ende eingefügt und werden Zeilen dort ggf. gelöscht.

Du müsstest schon etwas mehr Infos geben.

Gruß

M.O.

Answer 2

Hallo M.O.,

das Stimmt, eine Verlinkung wäre von Vorteil gewesen. Danke für die Anmerkung!

Die Namen in "Verkaufsgruppen" können nur einmal vorkommen und sind vorgegeben, also es werden keine Zeilen im Tabellenblatt "Verkaufsgruppen" entfernt oder hinzugefügt. Die Namen stehen von B3:B214. es werden jediglich "ja's" eingefügt odet entfernt bzw. durch ein "nein" ersetzt.
Das Problem ist, dass wenn man die Tabelle "Verkaufsgruppen" mit "Ja" befüllt und die Liste generiert, aber später noch weitere "JA's" hinzufügt, die Liste komplett neu erstellt wird und die "Namen" in der Tabelle" Gießerei" erscheinen dann Doppelt.

Gibt es evtl. einen Befehl mit dem man sagen kann, dass wenn der jeweilige "Name" bereits im Worksheet "Giesserei" vorkommt, keine neuen Zeilen eingefügt werden?

Könnte man eine Löschung vornehmen, wenn man das "ja" in den Spalten "D3:D214" durch ein "Nein" ersetzt?

Kenne mich leider nicht sehr gut mit VBA und dessen Möglichkeiten aus.

LG peyd

Answer 3

Hallo peyd,

mit einem einfachen Befehl ist es leider nicht getan.
Ich habe das Makro daher etwas erweitert. Es liest alle Daten mit "Ja" aus. Man muss im Arbeitsblatt Verkaufsgruppen nur ein gesetztes "Ja" löschen, damit die betreffenden Zeilen im Tabellenblatt Giesserei verschwinden.
Die manuell eingegeben Daten aus dem Tabellenblatt Giesserei werden in ein Feld eingelesen und nach dem Kopieren der Namen mit Ja aus dem Arbeitsblatt Verkaufsgruppen wieder den Namen - soweit diese noch vorhanden sind - zugeordnet.

Sub ja_uebernehmen()

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


'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

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

'prüfen, ob arrzeile > 0

If arrZeile < 1 Then
pruef = False
Else
pruef = True
End If

If pruef = True Then
'Feld neu dimensionieren
ReDim ArrayC(arrZeile, 3)

'Daten aus Tabelle Giesserei, Spalte C in das Feld einlesen
zeile = 5
For i = 1 To arrZeile
ArrayC(i, 0) = Worksheets("Giesserei").Cells(zeile, 1).Value 'Name in Array schreiben
ArrayC(i, 1) = Worksheets("Giesserei").Cells(zeile, 3).Value 'Wert aus VOK
ArrayC(i, 2) = Worksheets("Giesserei").Cells(zeile + 1, 3).Value 'Wert aus BEMI
ArrayC(i, 3) = Worksheets("Giesserei").Cells(zeile + 2, 3).Value 'Wert aus Invest
zeile = zeile + 3 'Zähler für Zeile erhöhen
Next i

'Nun Inhalt des Blattes Giesserei ab Zeile 5 löschen
lzeile = Worksheets("Giesserei").Cells(Rows.Count, 2).End(xlUp).Row
With Worksheets("Giesserei")
.Range(.Cells(5, 1), .Cells(lzeile, 3)).EntireRow.Delete
End With

End If

'Tabellenblatt Giesserei neu aufbauen
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
lzeile = Worksheets("Giesserei").Cells(Rows.Count, 2).End(xlUp).Row


'Vorhandene Daten ggf wieder in Spalte C schreiben

If pruef = True Then

zeile = 5

For j = 1 To (lzeile - 4) / 3

For i = 1 To UBound(ArrayC)

If Worksheets("Giesserei").Cells(zeile, 1).Value = ArrayC(i, 0) Then
Worksheets("Giesserei").Cells(zeile, 3) = ArrayC(i, 1) 'Wert in VOK schreiben
Worksheets("Giesserei").Cells(zeile + 1, 3) = ArrayC(i, 2) 'Wert in BEMI schreiben
Worksheets("Giesserei").Cells(zeile + 2, 3) = ArrayC(i, 3) 'Wert in Invest schreiben
End If

Next i

zeile = zeile + 3

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 & ";""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

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Probiere das Makro erst einmal in einer Testdatei aus.

Gruß

M.O.

Answer 4

hi all ^^

makros erfordern einigen Einsatz,wenn dann die Fragesteller crossposten,
sinkt sicherlich die Motivation der zu antwortenden und ist nun zum Nachteil der Fragesteller

gruss nighty

Answer 5

Hallo M.O.,

wieder eine geniale Lösung von dir!!! Auf sowas muss man erstmal kommen, Hut ab :)
das Makro hat auf Anhieb funktioniert und macht genau das was ich will!
Vielen vielen Dank ;-)

@nighty
das crossposting war nur, weil es, wie immer auf Arbeit, schnell gehen musste -.-
Wenn das deine Motivation gesenkt hat, dann wird es auch nicht mehr vorkommen :)

LG peyd

Answer 6

Hallo peyd,

danke für die (positive) Rückmeldung :-).

Gruß

M.O.

Answer 7

Hallo,

bräuchte noch ein kleines Update :P
Was müsste ich an dem Makro ändern, wenn jetzt nicht nur die Spalte C manuelle Daten enthalten und behalten soll, sondern auch Spalten D bis I (also Spalten 3-10 sollen in ein anderes Feld dimesioniert und wieder eingefügt werden).

könnte man anstatt nur die Spalte C, auch eine bestimmte Range (in dem Fall Spalten C bis I) neu dimensionieren und wieder einfügen?

Lg peyd

Answer 8

Hallo peyd,

versuch mal, ob es so klappt:

Sub ja_uebernehmen2()

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 3


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

For z = 0 To 2
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, 2).End(xlUp).Row
With Worksheets("Giesserei")
.Range(.Cells(5, 1), .Cells(lzeile, 3)).EntireRow.Delete
End With

End If

'Tabellenblatt Giesserei neu aufbauen
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
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 3

For i = 1 To UBound(ArrayC) Step 3

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


For z = 0 To 2
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 + 3

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 & ";""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

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 9

Hallo M.O.,

Sorry für die späte Antwort. Bin erst jetzt zum testen des Makros gekommen und es funktioniert wie alle deine Ansätze auf Anhieb ;-)
Vielen Dank dafür!!!

Ich möchte das Makro aber nochmals erweitern :-P , indem ich statt 3 zeilen nun 4 zeilen einfügen lasse d.h. es kommt eine Zeile bei den manuellen Angaben dazu und eine Zeile bei den Summen.

Habe das Makro schon angepasst aber leider erscheint beim dimesionieren des Feldes (im Makro FETT markierte Bereiche) die Fehlermeldung: "Index außerhalb des gültigen Bereiches". Habe den Bereich irgentwo falsch definiert aber finde den Fehler einfach nicht -.-

Hier das geänderte Makro:

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
[b] 'Feld neu dimensionieren
ReDim ArrayC(lzeile - 5, 8)

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

For zeile = 5 To lzeile Step 4


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

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

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

End If

'Tabellenblatt Giesserei neu aufbauen
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:A8").EntireRow.Insert 'Zeilen einfügen
.Cells(5, 2) = "Anlaufkosten"
.Cells(6, 2) = "VOK" 'Text einfügen
.Cells(7, 2) = "BEMI"
.Cells(8, 2) = "Invest"
.Cells(5, 10) = "=SUM(RC[-7]:RC[-1])" 'Zeilensummen Spalte J bilden
.Cells(6, 10) = "=SUM(RC[-7]:RC[-1])"
.Cells(7, 10) = "=SUM(RC[-7]:RC[-1])"
.Cells(8, 10) = "=SUM(RC[-7]:RC[-1])"

With .Range("A5:A8") '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
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 8
Worksheets("Giesserei").Cells(zeile + z, 3 + 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 & ";"&q

Answer 10

Hallo Peyd,

du hast den ursprünglichen Code von

'Feld neu dimensionieren
ReDim ArrayC(lzeile - 4, 7)

in

ReDim ArrayC(lzeile - 5, 8)

geändert.

Die Idee dahinter ist, dass in den ersten vier Zeilen Überschriften etc stehen, die nicht in das Array eingelesen werden müssen und daher das Array entsprechend kleiner dimensioniert werden kann.
Wenn du das Array um 1 Feld verkürzt (da du statt 4 jetzt 5 abziehst), aber weiterhin von Zeile 5 bis zum Ende die Daten einliest, dann ist das Array mit dem zweitletzten Datensatz bereits gefüllt und bei der letzten Zeile kommt dann die Fehlermeldung.

Also ändere die Dimensionierung des Arrays entsprechend oder beginne das Einlesen eine Zeile später (statt Zeile = 5 dann Zeile = 6), also die Codeteile

For zeile = 5 To lzeile Step 4
..
zeile = 5

For j = 1 To lzeile Step 4

Gruß

M.O.