AW: Sortieren und in Blatt einfügen
24.08.2006 13:00:33
Harald
Hi,
da sich bisher keiner gemeldet hat, hier ne vba -Krücke.
Ins Standardmodul, ggf Bereiche anpassen und dafür sorgen, dass die notwendigen Blattnamen vorhanden sind (wegen Zeitmangel meinerseits nicht eingebaut)
Aber villeicht hilfts ja schon so.
Sub gurke()
Dim Lrow As Long, LrowJ As Long, x As Long, suche As String, blatt As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Spalte ("J" = 10) für Spezialfilter ohne Duplikate, leeren
Columns(10).ClearContents
'letzte gefüllte Zeile in Spalte A
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
'Spezialfilter ohne Duplikate nach Spalte J
Range("A1:A" & Lrow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("J1" _
), Unique:=True
'letzte gefüllte Zeile in Spalte J
LrowJ = Cells(Rows.Count, 10).End(xlUp).Row
'Filterschleife
For i = 2 To LrowJ
suche = Cells(i, 10)
Range("A1").AutoFilter Field:=1, Criteria1:=suche
On Error GoTo ende 'bei Fehler(z.B.Zielblattname nicht vorhanden) abbrechen
Set blatt = Sheets(suche)
'1. freie Zeile in Zielblatt
x = blatt.Cells(Rows.Count, 1).End(xlUp).Row + 1
'gefilterte Daten aus Spalte A und B ins Zielblatt kopieren
ActiveSheet.Range("A2:B" & Lrow).SpecialCells(xlCellTypeVisible).Copy blatt.Cells(x, 1)
Next i
'Autofilter aus, Spalte J leeren
With ActiveSheet
.Range("a1").CurrentRegion.AutoFilter
.Columns(10).ClearContents
End With
ende:
If Err.Number > 0 Then MsgBox "Es ist ein Fehler aufgetreten"
With Application
.CutCopyMode = False
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Gruss Harald