Makro in Excel programmieren - Zeilen x-mal kopieren
Hallo,
ich brauche dringend Hilfe bei der Programmierung eines Makros in Excel. Ziel soll es sein Zeilen (Spalte B) aus Tabellenblatt1 x-mal (Zahl, die in Spalte A steht) in Tabellenblatt2 zu kopieren. Hier ein Beispiel, wie ich das meine:
Tabellenblatt 1:
Spalte A..... Spalte B
3................. Katze
2................. Vogel
4................. Hund
Ziel in Tabellenblatt 2:
Spalte A
Katze
Katze
Katze
Vogel
Vogel
Hund
Hund
Hund
Hund
Ich hab schon vieles probiert und es u.a. geschaft ganze Spalten mit Hilfe eines Makros von Tabellenblatt1 in Tabellenblatt2 zu kopieren, also z.B. Spalte A aus Tabellenblatt1 in Spalte A des Tabellenblattes2. Oder auch eine Zelle (A1) entsprechend der angegebenen Zahl (in Spalte A) darunter x-mal einzufügen. Aber ich schaffe es nicht, dass die Zelle in Spalte B in Abhängigkeit vom Wert, der in Spalte A steht, x-mal in einem neuen Tabellenbaltt einzufügen.
Ich brauche das Makro für die Arbeit, um die Erstellung von Rechnungen zu vereinfachen.
Ich freue mich über jede Hilfe und hoffe, dass mir jemand mit der Programmierung helfen kann. Excel-VBA für Dummies war mir bisher leider keine groe Hilfe :(
1 Antwort
Ich habe da mal auf die Schnelle was "zusammengestrickt", was zumindest bei meinem Versuch funktioniert hat.
Ist aber ohne Fehlerroutine etc.
Schau mal ob Du damit was anfangen kannst:
Sub Vermehren()
Dim Zelle As Range
Dim i1 As Integer
Dim i2 As Integer
For Each Zelle In Sheets("Tabelle1").Range("B1:B100")
If Not IsEmpty(Zelle) Then
For i1 = 1 To Zelle.Offset(0, -1)
i2 = i2 + 1
Sheets("Tabelle2").Cells(i2, 1).Value = Zelle.Value
Next i1
End If
Next Zelle
End Sub
Dazu musst Du daraus eine Ereignis-Code machen.
Mach mal einen Rechtsklick auf den Tabellenreiter in Tabelle1 (unten, da wo Tabelle1 steht) und gehe dann auf "Code anzeigen...".
In das große Fenster des VBA-Editors, der sich dann öffnet kopierst Du folgenden, erweiterten Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A100")) Is Nothing Then
Dim Zelle As Range
Dim i1 As Integer
Dim i2 As Integer
For Each Zelle In Sheets("Tabelle1").Range("B1:B100")
If Not IsEmpty(Zelle) Then
For i1 = 1 To Zelle.Offset(0, -1)
i2 = i2 + 1
Zelle.Copy Sheets("Tabelle2").Cells(i2, 1)
Next i1
End If
Next Zelle
End If
End Sub
Wie gesagt, da fehlt immer noch eine Fehlerroutine (wenn Du in Spalte A einen Buchstaben eingibst, erhältst Du eine Fehlermeldung) und der Bereich ("A1:A100") ist nicht flexibel.
Falls Du das noch brauchst und nicht selber hin bekommst, melde Dich nochmal.
Korrekturen hat immer der Teufel gesehen: Wenn Du eine Anzahl verringerst, bleiben die überzähligen Alt-Einträge stehen und müssen manuell entfernt werden.
oder man entfernt per Makro hier automatisch die gesamten vorher gesetzten Spalteneinträge in Tabelle2 (führe ich aber jetzt nicht mehr aus, obwohl einfach möglich)
Deine Arbeit, das zu tun und das Makro neu zu starten ist sicherlich geringer als die Arbeit von Oubyi und ggf auch mir, das zu korrigieren (und auszuprobieren)...
Super, das funktioniert richtig toll. Ich hab den Modul- und Tabellencode für mich noch ein bissl modifiziert. Ich habe jetzt aber doch noch ein kleines Problem:
Tabellenblatt1
3 (Spalte A1) maus (Spalte B1)
2 (Spalte A2) katze (Spalte B2)
dann steht in Tabellenblatt2 folgendes:
maus
maus
maus
katze
katze
Alles soweit richtig. Ändere ich aber nun bspw in Tabellenblatt1 Spalte A1 von 3 auf 2, dann passiert folgendes in Tabellenblatt2:
maus
maus
katze
katze
katze
Es sollte aber egt so aussehen:
maus
maus
katze
katze
Also was muss am Code geändert werden, dass sozusagen alles in Tabellenblatt2 gelöscht und neu geschrieben wird?
möglicherweise hilft es, am Anfang von Oubyis Worksheet_change noch einen Löschbefehl zu setzen:
Worksheets("Tabelle2"),Range("A1:A999").clear 'oder clearcontents (erhält Formate)
Könnte aber sein, dass da erst mal ein Worksheets(..2).activate
und danach wieder ein
Worksheets(...1).activate
notwendig ist,
probiers selber aus!
Stimmt, daran, dass die alten Einträge bei einer kürzeren Liste nicht gelöscht werden, hatte ich nicht gedacht.
Aber das sollte kein Problem sein (wie lamiam schon schreibt):
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A100")) Is Nothing Then
Sheets("Tabelle2").Range("A:A").ClearContents
Dim Zelle As Range
Dim i1 As Integer
Dim i2 As Integer
For Each Zelle In Sheets("Tabelle1").Range("B1:B100")
If Not IsEmpty(Zelle) Then
For i1 = 1 To Zelle.Offset(0, -1)
i2 = i2 + 1
Zelle.Copy Sheets("Tabelle2").Cells(i2, 1)
Next i1
End If
Next Zelle
End If
End Sub
Um die Performance zu optimieren kannst Du den Lösch-Bereich auch eingrenzen:
Sheets("Tabelle2").Range("A1:A1000").ClearContents
ich grenze den neuerdings immer deshalb ein (v.a. bei Formeln), weil OO/LO kein A:A akzeptiert und daran die ansonsten einwandfreie Übersetzung scheitern kann (bzw Fehler stehen bleibt).
Bei Makros zZt für mich ü'flüssig, weil ich in LO eh noch nicht programmieren kann!
DH!
auf die Schnelle krieg ich sowas nicht hin, aber dank Deiner Vorlage wars schnell modifiziert:
und samt Formaten kriegst du es rüber, wenn Du anstatt
Sheets("Tabelle2").Cells(i2, 1).Value = Zelle.Value
folgende Zeile einfügst:
Zelle.Copy Destination:=Sheets("Tabelle2").Cells(i2, 1)
(das Destination:= kann glaubbe ich entfallen, aber der Klarheit/Lesbarkeit halber füge ich das üblicherweise mit ein).
Stimmt.
Wenn das so gewünscht ist, dann muss ".copy" helfen. Das "Destination:=" lasse ich - der Faulheit wegen ㋛ - meist weg, aber Du hast natürlich Recht, so ist der Code besser zu lesen.
Super, dass funktioniert schon mal recht gut :)!!! Vielen Dank!
Was ich festgestellt habe ist, dass sich die Angaben im Tabellenblatt2 nicht automatisch ändern, wenn in Tabellenblatt1 die Anzahl in Spalte A geändert wird. Was ich meine ist, dass ich das Makro dann noch mal ausführen muss. Ist es möglich eine automatische Änderung in den Code mit einzubinden?