PDA

Vollständige Version anzeigen : Tabelle nach Artikel Sortieren


Turbinchen
01.05.2009, 07:21
Hallo zusammen

Also ich hab ein kleines Problemchen. Und zwar folgendes. Ich erhalte jeden Monat eine CSV Datei. In dieser Datei ist ersichtlich, wer wann was für Material bezogen hat.
Nun lassen sich die verschiedenen Artikel in Obergruppen einteilen. Diese Obergruppen haben Gruppennummern. A1, A2, A3 usw....
In der CSV Datei steht in der Spalte B diese Nummer.
Nun möchte ich folgendes, dass Excel mir die Tabelle nach Gruppennummern sortiert und dann alle Artikel mit der Gruppennummer A1 in ein neues Tabellenblatt mit dem Namen der Gruppennummer kopiert.
Ich weiss ich kann das auch mit Hilfe des Autoilters machen und dann per Hand kopieren, aber bei fast 80 Artikelgruppen ist das ein wenig mühsam.
Kann ich das irgendwie via VBA lösen?

Danke für eure Hilfe


LG Turbinchen

EarlFred
01.05.2009, 07:59
Hallo Turbinchen,

schau Dir mal folgenden Code an, ob Du damit was anfangen kannst:

Option Explicit
Sub AufBlätterAufteilen()
Dim lngCounter As Long, lngZielZeile As Long
Dim wsQuelle As Worksheet, wsNeu As Worksheet

Dim bolScrUpd As Boolean

bolScrUpd = Application.ScreenUpdating
Application.ScreenUpdating = False

Set wsQuelle = ActiveSheet

'sortieren
Columns("B:B").Sort Key1:=Range("B1"), Order1:=xlAscending

With wsQuelle
For lngCounter = 1 To .Cells(Rows.Count, 2).End(xlUp).Row
'ggf. neues Blatt anlegen
If Not BlattExistiert(.Cells(lngCounter, 2)) Then
Set wsNeu = Sheets.Add(after:=Sheets(Sheets.Count))
wsNeu.Name = .Cells(lngCounter, 2)
wsQuelle.Activate
End If
'Zeile kopieren
lngZielZeile = Sheets(Cells(lngCounter, 2).Value).Cells(Rows.Count, 2).End(xlUp).Row + 1
Rows(lngCounter).Copy Destination:=Sheets(.Cells(lngCounter, 2).Value).Rows(lngZielZeile)
Next lngCounter
End With

Application.ScreenUpdating = bolScrUpd

Set wsNeu = Nothing
Set wsQuelle = Nothing
End Sub

Public Function BlattExistiert(ByVal strBlattname As String) As Boolean
On Error Resume Next
BlattExistiert = Not ActiveWorkbook.Worksheets(strBlattname) Is Nothing
End Function

Grüße
EarlFred

Turbinchen
01.05.2009, 08:20
Herzlichen Dank, das ist genau das was ich gesucht habe. Vielen Vielen Dank :-)

EarlFred
01.05.2009, 08:28
Hallo Turbinchen,

danke für die Rückmeldung. Gern geschehen!

Grüße
EarlFred