Clever-Excel-Forum

Hey,

Ja genau also das ist zwar noch nie passiert, aber schadet ja nicht das zu berücksichtigen. :)

Hallöchen,

hier ist jetzt erst mal der nächste Stand. Ist noch nicht 100% - siehe Hinweis mit der Verrechnung der leeren Zeilen - , aber ich mach jetzt erst mal Schluss für heute und bei Bedarf morgen weiter.

Modul Modul3

Sub Makro2() 
'Variablendeklarationen 
'Long 
Dim lLRow&, lLCol&, lRowDiff& 
    'Mit dem aktiven Blatt 
    With ActiveSheet 
      'erst mal in Spalte A und B Leerzeichen entfernen 
      .Columns(1).Replace What:=" ", Replacement:="", LookAt:=xlPart 
      .Columns(2).Replace What:=" ", Replacement:="", LookAt:=xlPart 
      'erste zu kopierende Datenspalte aktivieren 
      .Cells(1, 5).Activate 
      'Solange in der aktiven Zelle Daten stehen 
      Do While ActiveCell.Value <> "" 
        'letzte belegte zelle in Spalte B feststellen (zum spaeteren Einfuegen) 
        lLRow = .Cells(Rows.Count, 2).End(xlUp).Row 
        lLCol = ActiveCell.Column 
        'eventuelle Leerzeichen entfernen - scheinbar leere Zellen haben alle eins ... 
        .Range(ActiveCell.Resize(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 3).Address).Replace What:=" ", Replacement:="", LookAt:=xlPart 
        'differenz zwischen erster Datenzeile und letzter Datenzeile des vorigen Bereiches 
        'Hinweise: 
        'Zeile 2 muss dabei ab 2. Reihe leer sein 
        'Eventuell sind noch Zeilenkorrekturen noetig. 
        lRowDiff = .Cells(1, lLCol).End(xlDown).Row - .Cells(Rows.Count, lLCol - 3).End(xlUp).Row 
        'Wenn vorige Spalte länger ist als aktuelle, dann nur von oben aus gehen 
        If lRowDiff < 0 Then 
          lRowDiff = .Cells(1, lLCol).End(xlDown).Row - 1 
        Else 
          lRowDiff = .Cells(Rows.Count, lLCol - 3).End(xlUp).Row + 1 
        End If 
        'sicherheitshalber nachschauen, ob was zu tun ist - anhand nicht leerer Zellen 
        If WorksheetFunction.Subtotal(103, .Range(ActiveCell.Resize(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 3).Address)) > 3 Then 
          'sichtbare Zellen im Datenbereich kopieren 
          .Range(ActiveCell.Offset(lRowDiff).Resize(.Cells(Rows.Count, lLCol).End(xlUp).Row - lRowDiff, 3).Address).SpecialCells(xlVisible).Copy 
          'und an Spalte B (und C und D) anhaengen 
          .Cells(lLRow + 1, 2).PasteSpecial Paste:=xlPasteValues 
        'Ende sicherheitshalber nachschauen, ob was zu tun ist - anhand nicht leerer Zellen 
        End If 
        'naechste Zelle aktivieren - 3 Spalten weiter 
        Cells(1, lLCol).Offset(0, 3).Activate 
      'Ende Solange in der aktiven Zelle Daten stehen 
      Loop 
   'Ende Mit dem aktiven Blatt 
   End With 
End Sub 
 

Huhu,

das sieht schon sehr gut aus, aber ja es scheint tatsächlich noch ein paar Problemchen zu geben. Mir ist aufgefallen, dass viele Leerzeilen richtig übernommen wurden aber auch einmal statt 6 Leerzeilen nur 5 kopiert wurden und teilweise wurden auch welche noch nicht übernommen. Der Feierabend sei dir selbstverständlich mehr als gegönnt, ich bin froh, dass es überhaupt schon so gut läuft

Hallöchen,

anbei der nächste Versuch. Die Zeilenzahl sollte jetzt passen.

Mir ist allerdings wieder ein Sonderfall eingefallen. Wenn eine oder mehrere Reihen leer sind, werden bei der nächsten Reihe mit Daten alle Leerzeilen über den Daten kopiert, außer der Zeile 2 und ohne Rücksicht darauf, wo das Ende irgendwo bei der letzten Reihe weiter links war.

Sub Makro2()
'Variablendeklarationen 
'Long 
Dim lLRow&, lLCol&, lRowDiff&
    'Mit dem aktiven Blatt 
    With ActiveSheet
      'erst mal in Spalte A und B Leerzeichen entfernen 
      .Columns(1).Replace What:=" ", Replacement:="", LookAt:=xlPart
      .Columns(2).Replace What:=" ", Replacement:="", LookAt:=xlPart
      'erste zu kopierende Datenspalte aktivieren 
      .Cells(1, 5).Activate
      'Solange in der aktiven Zelle Daten stehen 
      Do While ActiveCell.Value <> ""
        'letzte belegte zelle in Spalte B feststellen (zum spaeteren Einfuegen) 
        lLRow = .Cells(Rows.Count, 2).End(xlUp).Row
        lLCol = ActiveCell.Column
        'eventuelle Leerzeichen entfernen - scheinbar leere Zellen haben alle eins ... 
        .Range(ActiveCell.Resize(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 3).Address).Replace What:=" ", Replacement:="", LookAt:=xlPart
        'differenz zwischen erster Datenzeile und letzter Datenzeile des vorigen Bereiches 
        'Hinweise: 
        'Zeile 2 muss dabei ab 2. Reihe leer sein 
        'Eventuell sind noch Zeilenkorrekturen noetig. 
        lRowDiff = .Cells(1, lLCol).End(xlDown).Row - .Cells(Rows.Count, lLCol - 3).End(xlUp).Row
        'Wenn vorige Spalte länger ist als aktuelle, dann nur von oben aus gehen 
        If lRowDiff < 0 Then
          lRowDiff = .Cells(1, lLCol).End(xlDown).Row - 1
        Else
          lRowDiff = WorksheetFunction.Max(3, .Cells(Rows.Count, lLCol - 3).End(xlUp).Row)
        End If
        'sicherheitshalber nachschauen, ob was zu tun ist - anhand nicht leerer Zellen 
        If WorksheetFunction.Subtotal(103, .Range(ActiveCell.Resize(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 3).Address)) > 3 Then
          'sichtbare Zellen im Datenbereich kopieren 
          .Range(ActiveCell.Offset(lRowDiff).Resize(.Cells(Rows.Count, lLCol).End(xlUp).Row - lRowDiff, 3).Address).SpecialCells(xlVisible).Copy
          'und an Spalte B (und C und D) anhaengen 
          .Cells(lLRow + 1, 2).PasteSpecial Paste:=xlPasteValues
        'Ende sicherheitshalber nachschauen, ob was zu tun ist - anhand nicht leerer Zellen 
        End If
        'naechste Zelle aktivieren - 3 Spalten weiter 
        Cells(1, lLCol).Offset(0, 3).Activate
      'Ende Solange in der aktiven Zelle Daten stehen 
      Loop
   'Ende Mit dem aktiven Blatt 
   End With
End Sub

Du bist ein Held :18:  Es klappt jetzt alles richtig, soweit ich das beurteilen kann. Mir ist allerdings aufgefallen, dass ganz am Anfang nicht der erste Wert aus Zeile 3 genommen wird, sondern irgendwie erst aus Zeile 4 (das ist allerdings nur bei der ersten kopierten Reihe dann so), aber da muss man wahrscheinlich nur irgendwo ein -1 in den Code einfügen oder?

Zu dem Sonderfall: Also das dürfte soweit eigentlich niemals auftreten denke ich, da das Programm bewusst die Koordinaten fortlaufend in unterschiedlichen Spalten nach unten hin anordnet. Es kann höchstens mal sein, dass die ersten 8-9 Spalten leer sind und der erste Wert, dann bei Spalte 10 beginnt, aber das scheint der Code ohnehin zu beachten :)

Ich danke dir wirklich vielmals für alles!!!

Hallöchen,

in der Zeile

lRowDiff = WorksheetFunction.Max(3, .Cells(Rows.Count, lLCol - 3).End(xlUp).Row)

musst Du aus der Max(3 eine Max(2 machen.

Hallöchen,

Das Problem ist wohl, dass Du keine leeren Zellen hast. Da stehen Leerzeichen drin, deswegen auch der entsprechende Teil in meinem Code zum Entfernen selbiger.

Hab es jetzt mal sowohl manuell versucht, indem ich die Zeilen mit den vermutlichen Leerzeichen einmal gelöscht habe, sowie mit dem Code aus deinem Makro, habe das allerdings auf alle Spalten bezogen. Doch irgendwie werden immer noch alle Zeilen ab 3 gelöscht.

Habs auch mal mit einer kleinen Beispieltabelle ausprobiert da wird auch alles gelöscht, ich muss da wohl wirklich einen Fehler in meinem Code haben, denke ich

Hallöchen,

wenn Deine Tabelle so aussieht wie das Muster, dass Du gepostet hast, ist das normal. Da werden die Zeilen 3 bis 829 gelöscht, weil dort in Spalte A etwas steht. Wenn Du zuerst alles kopierst und anschließend die Zeilen löschst, sollte es doch passen?
Geht übrigens auch anders und schneller, aber dazu später. Soll ja das richtige schneller gehen und nicht das falsche