Zweiter Versuch
11.08.2014 15:49:00
Markus
Ok. Genauere Erklärung und den gesamten Code dazugelegt.
In Spalte K stehen meine zu suchenden Werte. Dieser werden sortiert und sollen dann in einen separate Datei kopiert werden. Das Makro fragt also Zeile für Zeile ab was in Spalte K drinsteht. Ändet sich was merkt es sich das und markiert den überprüften Bereich. Um die Eingrenzung des Bereiches geht es.
Das lastone steht für die letzte Zelle des Bereiches. Ist kein Problem, ist angepasst.
Das allcells steht für den zu suchenden Wert. Dieser ändert sich immer von Schleife zu Schleife.
Unten fett hervorgehoben wird der Bereich markiert in dem der suchende Wert aus Spalte K gefunden wurde "Range(allcells.address, lastone).Copy. Leider fehlen mir aber die Informationen von A bis L weil bei allcells.address die Adresse der ersten Zelle ausgegeben wird in dem mein Wert als erstes gefunden wurde (K3 --> Kxx --> Kyy usw.bis die Tabelle durch ist)
Was muss ich machen das allcells unberührt bleibt aber beim Kopieren alle Zellen von Spalte A bis zur letzten (lastone) kopiert werden?
Sub Sortieren()
Dim allcells As Range
Dim a As Range
Dim tkzdone() As String
ReDim tkzdone(0 To 1)
Dim ender As Range
Dim b As Range
orig = ActiveWorkbook.Name
last = Range("K3").End(xlDown).Offset(1, 0).Address
Range("K3", last).Sort Range("K3"), xlDescending
Set a = Range("K3", last)
For Each allcells In a
x = 0
found = False
Do Until x >= UBound(tkzdone)
If CStr(allcells) = tkzdone(x) Then
found = True
End If
x = x + 1
Loop
If found = False Then
If allcells.Value = "Prüfen" Then
ga = 1
End If
KST = CStr(allcells.Value)
tkzdone(UBound(tkzdone) - 1) = KST
ReDim Preserve tkzdone(0 To UBound(tkzdone) + 1)
Set b = Range(allcells.Address, last)
For Each ender In b
If Not CStr(ender.Value) = KST Then
lastone = ender.Offset(-1, 12).Address
GoTo ifound
End If
Next ender
ifound:
Range(allcells.Address, lastone).Copy
Workbooks.Add
Range("a3").Select
ActiveSheet.Paste
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
"G:\OPC\03_OPC_1\OPC_13\40_SFHM\60_Monitor\Budget_Kalkulation\Hellbauer\Aufgabe_Gernet\ _
Speicher\Einzeltabellen\" & KST & ".xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close True
Application.DisplayAlerts = True
Workbooks(orig).Activate
End If
Next allcells
End Sub