Datensätze verteilen und speichern
10.05.2005 17:57:49
winni
ich moechte alle Datensätze der gleichen Nummer (Spalte 1) in einer neuen Datei unter dem Namen dieser Nummer speichen. Die 1. Zeile mit den Ueberschriften soll mit uebernommen werden.
Spalte1 Spalte2 Spalte3
2; Meier ;weitere Daten
2; Mueller ;weitere Daten
3; Schulz ;weitere Daten
3; Klein ;weitere Daten
3; Gross ;weitere Daten
4; Dick ;weitere Daten
4; Dünn ;weitere Daten
Dazu habe ich im Forum das nachstehende Makro gefunden. Leider gelingt es
mir nicht, die damit erzeugten Arbeitsmappen automatisch unter dem Namen der
Bearbeitungsnummer (Nr_3, Nr_3, ...) zu speichern.
Wie muss ich das Makro ergänzen?
Danke für euere Hilfe!
Option Explicit
Sub EgaleSpeichern()
Dim rng As Range, rngCur As Range
Dim lngRow As Long
Application.ScreenUpdating = False
Set rngCur = Range("A1").CurrentRegion
rngCur.Sort _
key1:=Range("A2"), _
order1:=xlAscending, _
header:=xlYes
lngRow = 2
Do Until IsEmpty(rngCur.Cells(lngRow, 1))
If rngCur.Cells(lngRow, 1) <> rngCur.Cells(lngRow - 1, 1) Then
rngCur.AutoFilter _
field:=1, _
Criteria1:=rngCur.Cells(lngRow, 1)
Set rng = rngCur.SpecialCells(xlCellTypeVisible)
Workbooks.Add
ActiveSheet.Name = rngCur.Cells(lngRow, 1)
rng.Copy Range("A1")
End If
lngRow = lngRow + 1
Loop
Worksheets(1).Select
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = False
End Sub
Anzeige