Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1432to1436
1432to1436
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Tabbelle neu ordnen

Forumthread: Tabbelle neu ordnen

Tabbelle neu ordnen
24.06.2015 19:39:43
Thomas
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

Anzeige

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabbelle neu ordnen
25.06.2015 08:03:30
MCO
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

Anzeige
AW: Tabbelle neu ordnen
25.06.2015 08:32:14
Thomas
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

Anzeige
AW: Tabbelle neu ordnen
25.06.2015 12:21:20
Thomas
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

Anzeige
Korrektur
25.06.2015 12:41:09
MCO
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

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

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige