Sortieren und in Blatt einfügen

Forumthread: Sortieren und in Blatt einfügen

24.08.2006 09:54:30

markus

Hallo zusammen,
ich habe noch mal eine Frage und bräuchte eure Hilfe. Also folgendes ich habe in einer Zeile verschiedene Namenskürzel stehen.z.B. TBJS oder KDHF ich möchte nun diese Spalte durchsuchen und alle verschiedenen Kürzel TBJS z.B. in das entsprechende Blatt fortlaufend einsortieren. Also TBJS kommt 3mal vor in soll dann in Blatt TBJS einsortiert werden.
Habt Ihr eine Idee denke mal das wird nur mit VBA funktionieren.
Danke für Eure Hilfe
Gruß Markus

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

AW: Sortieren und in Blatt einfügen

24.08.2006 13:00:33

Harald

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

Beliebteste Forumthreads (12 Monate)

Forumthread: Sortieren und in Blatt einfügen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread