13.03.2016, 16:49
Hallöchen,
hier ist erst mal der korrigierte Code. Die aktive Zelle hat nach dem ersten Durchlauf nicht mehr gepasst daher waren auch Daten drin, aber eben nicht alle. Übrigens werden beim Kopieren auch die Überschriften mitgenommen, die müssen bestimmt auch noch weg, oder stören die nicht?
Modul Modul1
hier ist erst mal der korrigierte Code. Die aktive Zelle hat nach dem ersten Durchlauf nicht mehr gepasst daher waren auch Daten drin, aber eben nicht alle. Übrigens werden beim Kopieren auch die Überschriften mitgenommen, die müssen bestimmt auch noch weg, oder stören die nicht?
Modul Modul1
Sub Makro1() 'Variablendeklarationen 'Long Dim lLRow&, lLCol& 'Mit dem aktiven Blatt With ActiveSheet 'erst mal in Spalte B Leerzeichen entfernen .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 'filter setzen .Cells(1, 1).AutoFilter 'leere Zellen anhand erster Spalte im Datenbereich ausfiltern .Range(Cells(1, 1).Resize(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, ActiveCell.Column).Address).AutoFilter Field:=ActiveCell.Column, Criteria1:="<>" '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.Resize(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 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 'Autofilter zuruecksetzen .Cells(1, 1).AutoFilter '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