Excel - Makro um Zeilen in andere Sheets zu kopieren

Mauli

Hallo Zusammen!

Ich bin in Sachen Excel-Makros leider ein absoluter Newbie und stehe daher vor folgendem Problem:

In einer Tabelle sind unsere gesamten aktuellen Angebote aufgelistet.
Es gibt 4 Sheets: Überblick, KundeA, KundeB, Rest
Im Sheet Überblick steht in Spalte B der Kundenname.

Nun hätte ich gerne ein Makro, das folgendes macht:
- Durch das Sheet Überblick durchgehen
- wenn in Spalte B der Wert "KundeA" steht, soll die ganze Zeile in das Sheet "KundeA" kopiert werden
- wenn in Spalte B der Wert "KundeB" steht, soll die ganze Zeile dementsprechend in das Sheet "KundeB" kopiert werden
- trifft keins von beiden zu, soll die Zeile nach "Rest" kopiert werden

Kann man das irgendwie durch ein Makro realisieren?
Hab mich schon durch das ganze WWW gegoogelt, aber bisher hab ich den richtigen Ansatz leider noch nicht gefunden.

Wäre daher echt super, wenn mir hier irgendwer weiterhelfen könnte.

Vielen Dank schon mal!!!

Werbepost

Hallo!

Wenn du gerade an deiner Website arbeitest oder dein aktuelles Hosting überdenkst: Wir betreiben mit NetzLiving eine Hosting-Plattform, die speziell auf Performance, Sicherheit und einfache Verwaltung ausgelegt ist.

✔️ Schnelle Ladezeiten (optimiert für WordPress, WoltLab & Co.)
✔️ Deutsche Server & DSGVO-konform
✔️ Persönlicher Support (kein 0815-Ticket-System)

Mehr erfahren

Wenn du Fragen hast, kannst du dich gerne jederzeit an @Maximilian Rupp wenden

Hinweis:

ravenheart

Was bitte ist ein "Sheet" ?

Ich kenne bei Excel nur

Zellen
Zeilen
Spalten
Matrix
Blätter
Tabellen

Rabe

Mauli

Mit Sheet meine ich Arbeitsblätter.
Sorry wenn das unklar war!

Hoffe du kannst mir jetzt irgendwie ein bißchen weiterhelfen...
Bin hier echt am verzweifeln!

Tanto

Hallo Community :freu2:

Hier ein Beispiel ,wobei der Autofilter genutzt wird

Gruß Tanto :p

Code

Option Explicit
Sub FilterKopieren()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet
    Set ws1 = Worksheets("Überblick")
    Set ws2 = Worksheets("KundeA")
    Set ws3 = Worksheets("KundeB")
    Set ws4 = Worksheets("Rest")
    ws1.Range("B1").AutoFilter Field:=2, Criteria1:="KundeA"
    ws1.Rows("2:" & ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy ws2.Range("A" & ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    ws1.Range("B1").AutoFilter
    ws1.Range("B1").AutoFilter Field:=2, Criteria1:="KundeB"
    ws1.Rows("2:" & ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy ws3.Range("A" & ws3.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    ws1.Range("B1").AutoFilter
    ws1.Range("B1").AutoFilter Field:=2, Criteria1:="<>KundeA", Operator:=xlAnd, Criteria2:="<>KundeB"
    ws1.Rows("2:" & ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy ws4.Range("A" & ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    ws1.Range("B1").AutoFilter
End Sub

Alles anzeigen

Mauli

Hi!

Das Makro sieht an sich ja schon mal echt gut aus. Soweit ich das beurteilen kann.
Aber wenn ich das über meine Tabelle laufen lasse bekomme ich folgende Fehlermeldung:

> Laufzeitfehler '1004':
> Kann Teil einer verbundenen Zelle nicht ändern.

Hast du ne Ahnung wie ich das beheben kann?

Kann das evtl. daran liegen, dass in den ersten 5 Zeilen der Tabelle ne Art Header ist?
Die erste Zeile besteht zum Beispiel aus ner verbundenen Zelle von A bis W mit ner Überschrift.
Muss ich dem Makro sagen, das es erst bei Zeile 6 anfangen soll nach den Schlagwörtern zu suchen?
Wenn ja, kannst du mir verraten wie?

Auf jeden Fall aber erstmal danke, dass du dich meinem Problem angenommen hast!

Tanto

Hallo Mauli und Community

zu korrigieren
B6 statt B1
2 als Zeilenangabe sollte dann zu 6 geaendert werden

Noch ergänzend zu verbundenen zellen 8O

Verbundene Zellen sollten nicht genutzt werden,da diese bei Formeln wie auch VB immer wieder Probleme bereitet

Grüße euer Tanto :p

Tanto

Hallo Community und Mauli

Habe jetzt nicht so die zeit den Autofilter mit verbundenen Zellen zu testen

Daher eine Alternative,wenn die Laufzeit zufriedendstellend sein sollte

Liebe Grüße euer Tanto :p

Code

Option Explicit
Sub KopierenDreiTeilig()
    Call EventsOff
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim Zeilen As Long
    Set ws1 = Worksheets("Überblick")
    Set ws2 = Worksheets("KundeA")
    Set ws3 = Worksheets("KundeB")
    Set ws4 = Worksheets("Rest")
    ReDim Matrix(ws1.Cells(Rows.Count, 2).End(xlUp).Row - 5, 1)
    ws1.Activate
    Matrix() = Range("B6:B" & ws1.Cells(Rows.Count, 2).End(xlUp).Row)
    For Zeilen = 1 To ws1.Cells(Rows.Count, 2).End(xlUp).Row - 5
        If UCase(Matrix(Zeilen, 1)) = "KUNDEA" Then ws1.Rows(Zeilen + 5 & ":" & Zeilen + 5).Copy ws2.Range("A" & ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
        If UCase(Matrix(Zeilen, 1)) = "KUNDEB" Then ws1.Rows(Zeilen + 5 & ":" & Zeilen + 5).Copy ws3.Range("A" & ws3.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
        If UCase(Matrix(Zeilen, 1)) <> "KUNDEA" And UCase(Matrix(Zeilen, 1)) <> "KUNDEB" And Matrix(Zeilen, 1) <> "" Then ws1.Rows(Zeilen + 5 & ":" & Zeilen + 5).Copy ws4.Range("A" & ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    Next Zeilen
    Call EventsOn
End Sub

Alles anzeigen

Code

Public Sub EventsOff()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
End Sub

Code

Public Sub EventsOn()
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Mauli

Eine Frage noch zur Implementierung deines Makros:

Müssen die beiden anderen Quelltexte in andere Module rüberkopiert werden?
Oder einfach unter den Quelltext des ersten Teils?
Oder ganz woanders hin?

Auf jeden Fall hab ich bei beiden Varianten das gleiche Problem:
Nach Ausführen des Makros sind die Arbeitsblätter wo die Zeilen hinkopiert werden sollen immer noch leer.
Ne Fehlermeldung bekomm ich aber nicht mehr (liegt das evtl. an dem neuen Pogrammiercode...?).

Sorry, falls ich anfange zu nerven, aber es läuft halt immer noch nicht wie gewünscht...

Tanto

Hallo Mauli

PN ist an dich versendet worden :cool:

Grüße euer Tanto :razz:

Mauli

Danke, Datei ist unterwegs!

Grüße!

Mauli

Hi!

So, hab nun die Zeit gefunden, deine Datei mal durchzuchecken.
Klappt ja an sich schon echt gut.
Aber ein Problem gibt es noch: Die erste in das jeweilige Worksheet kopierte Zeile steht immer in Zeile 5. Da soll sie aber ncht hin, sondern die Liste soll erst von Zeile 6 an beginnen.
In deinem Makro-Code fand ich allerdings nur Sechsen.
Hast du ne Ahnung, wie man es hinbekommt, dass das Kopieren erst eine zeile später passiert?

Besten Dank auf jeden Fall schon mal für deine Arbeit!

Tanto

Hallo Community

Nachdem ich Verbundene Zellen entfernte,kam dieses Makro zum Einsatz( bis jetzt ).

Gruß euer Tanto :p

Code

Option Explicit
Sub FilterKopieren()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet
    Set ws1 = Worksheets("Überblick")
    Set ws2 = Worksheets("Kunde A")
    Set ws3 = Worksheets("Kunde B")
    Set ws4 = Worksheets("Rest")
    ws1.Range("B6").AutoFilter Field:=2, Criteria1:="Kunde A"
    ws1.Rows("6:" & ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy
    ws2.Range("A" & ws2.Cells(Rows.Count, 6).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues
    ws2.Range("M" & ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2) = Application.WorksheetFunction.Sum(ws2.Range("M6:M" & ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2))
    ws2.Range("N" & ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row) = Application.WorksheetFunction.Sum(ws2.Range("N6:N" & ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row))
    ws1.Range("B6").AutoFilter
    ws1.Range("B6").AutoFilter Field:=2, Criteria1:="Kunde B"
    ws1.Rows("6:" & ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy
    ws3.Range("A" & ws3.Cells(Rows.Count, 6).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues
    ws3.Range("M" & ws3.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2) = Application.WorksheetFunction.Sum(ws3.Range("M6:M" & ws3.UsedRange.SpecialCells(xlCellTypeLastCell).Row - 1))
    ws3.Range("N" & ws3.UsedRange.SpecialCells(xlCellTypeLastCell).Row) = Application.WorksheetFunction.Sum(ws3.Range("N6:N" & ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row - 1))
    ws1.Range("B6").AutoFilter
    ws1.Range("B6").AutoFilter Field:=2, Criteria1:="<>Kunde A", Operator:=xlAnd, Criteria2:="<>Kunde B"
    ws1.Rows("6:" & ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy
    ws4.Range("A" & ws4.Cells(Rows.Count, 6).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues
    ws4.Range("M" & ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2) = Application.WorksheetFunction.Sum(ws4.Range("M6:M" & ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row - 1))
    ws4.Range("N" & ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row) = Application.WorksheetFunction.Sum(ws4.Range("N6:N" & ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row - 1))
    ws1.Range("B6").AutoFilter
    Application.CutCopyMode = False
    Range("A1").Activate
End Sub

Alles anzeigen

Tanto

Hallo liebe Community

Ich habe die betroffenen Befehle nun unterstrichen um eventuelle Positionen von Quelle wie Ziel zu verändern

Bei unklarheiten immer Fragen :pc:

Gruß euer Tanto :p

Code

Option Explicit
Sub FilterKopieren()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet
    Set ws1 = Worksheets("Überblick")
    Set ws2 = Worksheets("Kunde A")
    Set ws3 = Worksheets("Kunde B")
    Set ws4 = Worksheets("Rest")
    ws1.Range("[U]B6[/U]").AutoFilter Field:=2, Criteria1:="Kunde A"
    ws1.Rows("[U]6[/U]:" & [U]ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row[/U]).Copy
    ws2.Range("A" & [U]ws2.Cells(Rows.Count, 6).End(xlUp).Row + 1[/U]).PasteSpecial Paste:=xlValues
    ws2.Range("M" & [U]ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2[/U]) = Application.WorksheetFunction.Sum(ws2.Range("[U]M6[/U]:M" & [U]ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2[/U]))
    ws2.Range("N" & [U]ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row[/U]) = Application.WorksheetFunction.Sum(ws2.Range("[U]N6[/U]:N" & [U]ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row[/U]))
    ws1.Range("[U]B6[/U]").AutoFilter
    ws1.Range("[U]B6[/U]").AutoFilter Field:=2, Criteria1:="Kunde B"
    ws1.Rows("[U]6[/U]:" & [U]ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row[/U]).Copy
    ws3.Range("A" & [U]ws3.Cells(Rows.Count, 6).End(xlUp).Row + 1[/U]).PasteSpecial Paste:=xlValues
    ws3.Range("M" & [U]ws3.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2[/U]) = Application.WorksheetFunction.Sum(ws3.Range("[U]M6[/U]:M" & [U]ws3.UsedRange.SpecialCells(xlCellTypeLastCell).Row - 1[/U]))
    ws3.Range("N" & [U]ws3.UsedRange.SpecialCells(xlCellTypeLastCell).Row[/U]) = Application.WorksheetFunction.Sum(ws3.Range("[U]N6[/U]:N" & [U]ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row - 1[/U]))
    ws1.Range("[U]B6[/U]").AutoFilter
    ws1.Range("[U]B6[/U]").AutoFilter Field:=2, Criteria1:="<>Kunde A", Operator:=xlAnd, Criteria2:="<>Kunde B"
    ws1.Rows("[U]6[/U]:" & [U]ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row[/U]).Copy
    ws4.Range("A" & [U]ws4.Cells(Rows.Count, 6).End(xlUp).Row + 1[/U]).PasteSpecial Paste:=xlValues
    ws4.Range("M" & [U]ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2[/U]) = Application.WorksheetFunction.Sum(ws4.Range("[U]M6[/U]:M" & [U]ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row - 1[/U]))
    ws4.Range("N" & [U]ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row[/U]) = Application.WorksheetFunction.Sum(ws4.Range("[U]N6[/U]:N" & [U]ws4.UsedRange.SpecialCells(xlCellTypeLastCell).Row - 1[/U]))
    ws1.Range("[U]B6[/U]").AutoFilter
    Application.CutCopyMode = False
    Range("A1").Activate
End Sub

Alles anzeigen

Mauli

Hi!

Danke für die super Hilfe!

Nach kleiner Modifikation läuft das Makro jetzt wie gewünscht.

Alleine hätte ich das nie hinbekommen!

Tausend Dank!

Jetzt mitmachen!