pfeffis 11 Geschrieben 16. März 2009 Melden Teilen Geschrieben 16. März 2009 Hallo Gemeinde! Es gibt eine Tabelle mit Spalten A-G. Beispiel: A B C D E F G a1 b1 farbe1 farbe2 farbe3 farbe4 g1 a2 b2 farbe1 farbe2 farbe3 farbe4 g2 . . Diese Tabelle soll nach Ausführung eines Makros so aussehen: A B C D a1 b2 farbe1 g1 a1 b2 farbe2 g1 a1 b2 farbe3 g1 a1 b2 farbe4 g1 a2 b2 farbe1 g2 . . . Das ganze soll nach dem Schema in Tabelle2 kopiert werden. dieses makro schnipsel habe ich als vorlage genommen, komme aber nicht so recht weiter :( Sub CopyPrim() Quelle = "Tabelle1" Ziel = "Tabelle2" Yziel = 1 With Sheets(Quelle) 'Durchlaufe alle Zeilen der Quelle For Yquelle = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row 'Durchlaufe 23x alle Spalten der Quelle For i = 1 To 23 For Xquelle = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column 'Zellinhalt kopieren Sheets(Ziel).Cells(Yziel, Xquelle) = .Cells(Yquelle, Xquelle) Next Yziel = Yziel + 1 Next Next End With End Sub Zitieren Link zu diesem Kommentar
d.stegemann 10 Geschrieben 16. März 2009 Melden Teilen Geschrieben 16. März 2009 Hallo pfeffis, eine wichtige Frage vorab... Unter welcher Office Version soll denn das Makro laufen? Gruß Dirk Zitieren Link zu diesem Kommentar
pfeffis 11 Geschrieben 16. März 2009 Autor Melden Teilen Geschrieben 16. März 2009 ms office 2003 und/oder 2007 Zitieren Link zu diesem Kommentar
d.stegemann 10 Geschrieben 16. März 2009 Melden Teilen Geschrieben 16. März 2009 Hallo pfeffis, ich habe nur Office 2000 da... aber ich denke der Code sollte auch bei dir laufen... Sub Makro1()'' Makro1 Makro' Makro am 16.03.2009 von Dirk aufgezeichnet''istart = 1 'Bereich x-Achse Anfangiend = 7 ' Bereich x-Achse Endeizeilenew = 1istartnew = 0sheets_num = ActiveWorkbook.Sheets.CountSheets(2).Select'MsgBox sheets_numizeilenzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row' MsgBox izeilenzahlFor izeile = 1 To izeilenzahl'MsgBox izeile For ispalte = istart To iend Sheets(2).Select Range(Cells(izeile, istart), Cells(izeile, istart)).Select ' MsgBox istart, vbCritical, izeile Selection.Copy Sheets(1).Select Select Case istart Case iend 'MsgBox izeilenew Range(Cells(izeilenew - istartnew, istartnew + 1), Cells(izeilenew, istartnew + 1)).Select ActiveSheet.Paste ihelper = izeilenew - istartnew + 1 Do While ihelper <= izeilenew Cells(ihelper, 1).Value = Cells(izeilenew - istartnew, 1).Value ihelper = ihelper + 1 Loop izeilenew = izeilenew + 1 istart = istart + 1 Case Else If istartnew > 2 Then izeilenew = izeilenew + 1 Else istartnew = istartnew + 1 End If Range(Cells(izeilenew, istartnew), Cells(izeilenew, istartnew)).Select ActiveSheet.Paste istart = istart + 1 ' MsgBox istartnew, vbCritical, izeilenew End Select Nextistart = 1istartnew = 0Next Sheets(2).Select Range(Cells(izeilenzahl, istart + 1), Cells(izeilenzahl, istart + 1)).Select Selection.Copy Sheets(1).Select Range(Cells(1, 2), Cells(izeilenew - 1, 2)).Select ActiveSheet.Paste Range(Cells(1, 1), Cells(1, 1)).SelectEnd Sub[/Code] Ich habe halt von Tabelle2 auf Tabelle1 kopiert. Das sollte aber kein Problem sein... Gruß Dirk Zitieren Link zu diesem Kommentar
pfeffis 11 Geschrieben 17. März 2009 Autor Melden Teilen Geschrieben 17. März 2009 WoW. vielen Dank. Kleines Problemchen noch: Die Werte sehen statt so A B C D a1 b2 farbe1 g1 a1 b2 farbe2 g1 a1 b2 farbe3 g1 a1 b2 farbe4 g1 so A B C D a1 b2 farbe1 farbe2 farbe3 farbe4 aus. Sprich spalte g wird gar nicht übernommen und die werte werden nur einmalig beim Sprung in die nächste zeile übernommen. bei spalte b steht nun auch immer eine 1 als wert drinnen. Stand vorm umwandeln: A B C D E F G a1 b1 farbe1 farbe2 farbe3 farbe4 g1 a2 b2 farbe1 farbe2 farbe3 farbe4 g2 Stand nach dem umwandeln: A B C D a1 1 farbe1 1 farbe2 1 farbe3 1 farbe4 a2 1 farbe1 1 farbe2 ... Zitieren Link zu diesem Kommentar
d.stegemann 10 Geschrieben 17. März 2009 Melden Teilen Geschrieben 17. März 2009 Ich hänge mal meine Datei mit ran... Die Befüllung der Spalten a und g erfolgt beim letzten Durchlauf pro Zeile(iend) der Quelltabelle. Spalte b wird nach durchlauf der Schleifen auf Basis der letzten Zeile der Quelltabelle gefüllt. Vielleicht sieht dein Blatt doch ein wenig anders aus :) Vielleicht interpretiert dein Office den Code auch ein wenig anders. Hilfreich könnten auch die msgboxen im Code sein. Nimm einfach die Kommentare raus, dann siehst du ja was passiert. Gruß Dirk Neu Microsoft Excel-Arbeitsblatt.zip Zitieren Link zu diesem Kommentar
Cybquest 36 Geschrieben 17. März 2009 Melden Teilen Geschrieben 17. März 2009 Hier noch ne Möglichkeit, angelehnt an Deinen Beispielcode: Sub CopyPrim() Dim varSpalte1 As Object Quelle = "Tabelle1" Ziel = "Tabelle2" YZiel = 1 With Sheets(Quelle) 'Durchlaufe alle Zeilen der Quelle For YQuelle = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row 'Durchlaufe 3. bis vorletzte Spalte der Quelle For XQuelle = 3 To .Cells.SpecialCells(xlCellTypeLastCell).Column - 1 'Zellinhalt umkopieren Sheets(Ziel).Cells(YZiel, 1) = .Cells(YQuelle, 1) Sheets(Ziel).Cells(YZiel, 2) = .Cells(YQuelle, 2) Sheets(Ziel).Cells(YZiel, 3) = .Cells(YQuelle, XQuelle) Sheets(Ziel).Cells(YZiel, 4) = .Cells(YQuelle, .Cells.SpecialCells(xlCellTypeLastCell).Column) YZiel = YZiel + 1 Next Next End With End Sub Zitieren Link zu diesem Kommentar
pfeffis 11 Geschrieben 17. März 2009 Autor Melden Teilen Geschrieben 17. März 2009 Danke euch beiden. Gibt es jetzt noch die Möglichkeit, wenn bspw. nur farbe1 und farbe2 in einer zeile stehen und farbe3, 4 etc. nicht befüllt sind gleich auf die nächste zeile zu springen? Tausend Dank nochmal Zitieren Link zu diesem Kommentar
Cybquest 36 Geschrieben 17. März 2009 Melden Teilen Geschrieben 17. März 2009 Like this? Sub CopyPrim() Dim varSpalte1 As Object Quelle = "Tabelle1" Ziel = "Tabelle2" YZiel = 1 With Sheets(Quelle) 'Durchlaufe alle Zeilen der Quelle For YQuelle = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row 'Durchlaufe 3. bis vorletzte Spalte der Quelle For XQuelle = 3 To .Cells.SpecialCells(xlCellTypeLastCell).Column - 1 'Zellinhalt umkopieren If .Cells(YQuelle, XQuelle) <> "" Then Sheets(Ziel).Cells(YZiel, 1) = .Cells(YQuelle, 1) Sheets(Ziel).Cells(YZiel, 2) = .Cells(YQuelle, 2) Sheets(Ziel).Cells(YZiel, 3) = .Cells(YQuelle, XQuelle) Sheets(Ziel).Cells(YZiel, 4) = .Cells(YQuelle, .Cells.SpecialCells(xlCellTypeLastCell).Column) YZiel = YZiel + 1 End If Next Next End With End Sub Zitieren Link zu diesem Kommentar
pfeffis 11 Geschrieben 17. März 2009 Autor Melden Teilen Geschrieben 17. März 2009 @cyberquest: Du bist ja mal geil :D Vielen Dank nochmal an euch beide! Klappt super und spart mir mindestens einen Tag arbeit :cool: Zitieren Link zu diesem Kommentar
Cybquest 36 Geschrieben 17. März 2009 Melden Teilen Geschrieben 17. März 2009 Danke :) Ist immer wieder schön, wenn man mit ein paar Zeilen Code jemanden glücklich machen kann ;) Zitieren Link zu diesem Kommentar
Empfohlene Beiträge
Schreibe einen Kommentar
Du kannst jetzt antworten und Dich später registrieren. Falls Du bereits ein Mitglied bist, logge Dich jetzt ein.