Tabbelle neu ordnen

Bild

Betrifft: Tabbelle neu ordnen
von: Thomas
Geschrieben am: 24.06.2015 19:39:43

hallo,
ich bin auf der suche nach einem Macro welches folgendes ausführt.
kopiere die Tabellenbereiche F bis I und m bis Q unter den bereich C bis h auf. Jedoch soll der Bereich c bis d um die entsprechend Anzahl nur runterkopiert werden.
Leider kann ich es nicht so gut erklären deshalb habe ich ein vorher nachher macro aufgezeichnet.
Super wäre wenn ich die betroffenen Spalten irgentwie in zellen bestimmen könnte ( eine kennzeichnung im Macro würde mir auch schon reichen wenn es einfacher ist).Habe es versucht in der Beispieltabelle darzustellen.
Die Anzahl der zu kopierenden zeilen ist sehr Variable man müsste mit dem Macro die jeweils letze Zeile bestimmen.
Das Ergebnis könnte in dem selben blatt bleiben aber auch ein anderes blatt wäre toll
es müsste dann nur immer das gleiche sein z.B. "Tabelle1aufgeteilt".
Die Überschrift der Tabelle spielt hier keine rolle.
Und das euordnen beginnt immer ab zeile 2.
Kann jemand soetwas schreiben? Oder hat so etwas schon ? vieleicht als link?
Ich habe leider nichts gefunden.
liebe grüsse von Thomas und vielen dank schon mal für eure Hilfe
https://www.herber.de/bbs/user/98446.xlsm

Bild

Betrifft: AW: Tabbelle neu ordnen
von: MCO
Geschrieben am: 25.06.2015 08:03:30
Moin!
Auf manche Dinge wärst du sicher selbst gekommen....
Bitte schön:

Sub Makro1()
    'letzte Zeile suchen in Spalte F
    lz = Cells(40, "F").End(xlUp).Row
    'letzte Zeile suchen in Spalte C
    lz_einf = Cells(40, "C").End(xlUp).Row + 1
    'A:C kopieren,Bereich verschieben
    Range("C2:E" & lz).Copy Range("C" & lz_einf)
    Range("J2:M" & lz).Cut Range("F" & lz_einf)
    
    'letzte Zeile neu setzen
    lz_einf = Cells(40, "C").End(xlUp).Row + 1
    Range("C2:E" & lz).Copy Range("C28")
    Range("N2:Q" & lz).Cut Range("F" & lz_einf)
    Range("C2").CurrentRegion.Interior.ColorIndex = xlNone
End Sub

Gruß, MCO

Bild

Betrifft: AW: Tabbelle neu ordnen
von: Thomas
Geschrieben am: 25.06.2015 08:32:14
Hallo MCO,
erstmal vielen Dank das Du mich unterstütz. Ich habe mich auch versucht siehe unten. Da sind aber noch die Bereiche welche kopiert bzw ausgescnitten werden nicht variabel ( wenn zeilen zu kommen geht es nicht mehr. ich glaube schleifen wären besser aber ich bekomme es nie hin. Sorry.
In deinem makro ist auch irgendwie noch ein Wurm drin. Wenn sich die Zeilenzahl verändert passt sich der Spaltenbereich c bis e nicht richtig an und der Bereich mit f bis i wird gänzlich verschluck.
Kannst Du Dir es noch mal anschauen?
https://www.herber.de/bbs/user/98460.xlsm
liebe grüsse thomas

Sub Zeile_kopieren()
    '1. Bereich kopieren
    Sheets("Tabelle1").Range("c2:e14").Copy
    'letzte Zeile in Tabelle1 aus Spalte c
    lz = Sheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Row + 1
    'Tabelle1, Zelle c in entsprechender Zeile markieren
    Sheets("Tabelle1").Select
    Range("c" & lz).Select
    'Daten einfügen
    ActiveSheet.Paste
    'Markierung aufheben (Zelle c.. markieren)
    Sheets("Tabelle1").Range("c" & lz).Select
    'Kopiermodus beenden
    Application.CutCopyMode = xlCopy
   
   ' das selbe noch mal
    
    '1. Bereich kopieren
    Sheets("Tabelle1").Range("c2:e14").Copy
    'letzte Zeile in Tabelle1 aus Spalte c
    lz = Sheets("Tabelle1").Cells(Rows.Count, 3).End(xlUp).Row + 1
    'Tabelle1, Zelle c in entsprechender Zeile markieren
    Sheets("Tabelle1").Select
    Range("c" & lz).Select
    'Daten einfügen
    ActiveSheet.Paste
    'Markierung aufheben (Zelle c.. markieren)
    Sheets("Tabelle1").Range("c" & lz).Select
    'Kopiermodus beenden
    Application.CutCopyMode = xlCopy
    
    '  spalte j -m
    
     '1. Bereich auschneiden
    Sheets("Tabelle1").Range("j2:m14").Cut
    'letzte Zeile in Tabelle1 aus Spalte c
    lz = Sheets("Tabelle1").Cells(Rows.Count, 6).End(xlUp).Row + 1
    'Tabelle1, Zelle c in entsprechender Zeile markieren
    Sheets("Tabelle1").Select
    Range("f" & lz).Select
    'Daten einfügen
    ActiveSheet.Paste
    'Markierung aufheben (Zelle f.. markieren)
    Sheets("Tabelle1").Range("f" & lz).Select
    'Kopiermodus beenden
    Application.CutCopyMode = xlCopy
    
    
    '  n  bis q
    
     '1. Bereich auschneiden
    Sheets("Tabelle1").Range("n2:q14").Cut
    'letzte Zeile in Tabelle1 aus Spalte c
    lz = Sheets("Tabelle1").Cells(Rows.Count, 6).End(xlUp).Row + 1
    'Tabelle1, Zelle c in entsprechender Zeile markieren
    Sheets("Tabelle1").Select
    Range("f" & lz).Select
    'Daten einfügen
    ActiveSheet.Paste
    'Markierung aufheben (Zelle f.. markieren)
    Sheets("Tabelle1").Range("f" & lz).Select
    'Kopiermodus beenden
    Application.CutCopyMode = xlCopy
    
   
    
   
End Sub


Bild

Betrifft: AW: Tabbelle neu ordnen
von: Thomas
Geschrieben am: 25.06.2015 12:21:20
Hallo,
bin am verzweifeln und auch ein wenig stolz. Das Macro funktioniert schon ein wenig.
Habe nur noch den Fehler das der Bereich c:e einmal zu viel kopiert wird. Ich weiss auch das es daran liegt das ich beim zweiten kopieren den zu kopierten Bereich zu gross markiere. Aber ich weiss leider nicht wie ich dies verhindere. Wie kann ich sagen füge den ersten Bereich zweimal untereinander ein?
Dann könnte ich den Abschnitt ' das selbe noch mal löschen?
liebe Grüsse Thomas

Sub Zeile_kopieren()
    '1. Bereich kopieren
    Range(Cells(2, 3), Cells(Cells(65536, 5).End(xlUp).Row, 5)).Copy  ' 2 = ab zeile 2, 3 = ab  _
spalte 3 - 5 kopieren
    'letzte Zeile in Tabelle1 aus Spalte c
    lz = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row + 1  ' erste leere zeile spalte 3
    'Tabelle1, Zelle c in entsprechender Zeile markieren
    ActiveSheet.Select
    Range("c" & lz).Select
    'Daten einfügen
    ActiveSheet.Paste
    'Markierung aufheben (Zelle c.. markieren)
    ActiveSheet.Range("c" & lz).Select
    'Kopiermodus beenden
    Application.CutCopyMode = xlCopy
   
   ' das selbe noch mal
    
    '1. Bereich kopieren
     Range(Cells(2, 3), Cells(Cells(65536, 5).End(xlUp).Row, 5)).Copy
    'letzte Zeile in Tabelle1 aus Spalte c
    lz = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row + 1
    'Tabelle1, Zelle c in entsprechender Zeile markieren
    ActiveSheet.Select
    Range("c" & lz).Select
    'Daten einfügen
    ActiveSheet.Paste
    'Markierung aufheben (Zelle c.. markieren)
    ActiveSheet.Range("c" & lz).Select
    'Kopiermodus beenden
    Application.CutCopyMode = xlCopy
    
    '  spalte j -m
    
     '1. Bereich auschneiden
    Range(Cells(2, 10), Cells(Cells(65536, 13).End(xlUp).Row, 13)).Cut
    'letzte Zeile in Tabelle1 aus Spalte c
    lz = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row + 1
    'Tabelle1, Zelle c in entsprechender Zeile markieren
   ActiveSheet.Select
    Range("f" & lz).Select
    'Daten einfügen
    ActiveSheet.Paste
    'Markierung aufheben (Zelle f.. markieren)
    ActiveSheet.Range("f" & lz).Select
    'Kopiermodus beenden
    Application.CutCopyMode = xlCopy
    
    
    '  n  bis q
    
     '1. Bereich auschneiden
    Range(Cells(2, 14), Cells(Cells(65536, 17).End(xlUp).Row, 17)).Cut
    'letzte Zeile in Tabelle1 aus Spalte c
    lz = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row + 1
    'Tabelle1, Zelle c in entsprechender Zeile markieren
    ActiveSheet.Select
    Range("f" & lz).Select
    'Daten einfügen
    ActiveSheet.Paste
    'Markierung aufheben (Zelle f.. markieren)
    ActiveSheet.Range("f" & lz).Select
    'Kopiermodus beenden
    Application.CutCopyMode = xlCopy
    
   
    
   
End Sub


Bild

Betrifft: Korrektur
von: MCO
Geschrieben am: 25.06.2015 12:41:09
Hallo!
Hatte noch die falschen END-Bezüge dringelassen.
Mit diesem Code klappt es:

Sub ordnen()
    'letzte Zeile suchen in Spalte F
    lz = Cells(Rows.Count, "F").End(xlUp).Row
    'letzte Zeile suchen in Spalte C
    lz_einf = Cells(Rows.Count, "C").End(xlUp).Row + 1
    'A:C kopieren,Bereich verschieben
    Range("C2:E" & lz).Copy Range("C" & lz_einf)
    Range("J2:M" & lz).Cut Range("F" & lz_einf)
    
    'letzte Zeile neu setzen
    lz_einf = Cells(Rows.Count, "C").End(xlUp).Row + 1
    Range("C2:E" & lz).Copy Range("C" & lz_einf)
    Range("N2:Q" & lz).Cut Range("F" & lz_einf)
    'Range("C2").CurrentRegion.Interior.ColorIndex = xlNone
End Sub
Gruß, MCO

Bild

Betrifft: Besten Dank an MCO
von: Thomas
Geschrieben am: 25.06.2015 15:55:01
Hallo MCO,
besten dank für die Hilfe es funktioniert super. Meine Gehversuche werfe ich gern in die Tonne.
liebe grüße thomas

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Tabbelle neu ordnen"