AW: Sortierung - unter best. Bedingungen
12.01.2010 16:04:10
fcs
Hallo Michel,
hier mein Vorschlag.
Ich weiss jetzt nicht ob du dich in der Nachherspalte mit den Farben vertan hast. Das Makro sortiert im Moment so ein, dass die Reihenfolge der 0850@-Nummern identisch sind. Kannst du aber im Code einfach anpassen.
Gruß
Franz
Sub Move0850_Line()
Dim Zelle750_1 As Range, Nr750 As String, Zelle850_1 As Range
Dim Zelle750_2 As Range, Zelle850_2 As Range
Dim vFind
Dim wks As Worksheet
Set wks = ActiveSheet
With wks
With .Columns(1)
'1. Position mit Suchbegriff finden
vFind = "0750@"
Set Zelle750_1 = .Find(what:=vFind, LookIn:=xlValues, lookat:=xlPart, _
after:=.Range("A1"), searchorder:=xlByRows, searchdirection:=xlNext)
If Zelle750_1 Is Nothing Then
MsgBox "Kein Element gefunden mit: " & vFind
Exit Sub
Else
Nr750 = Left(Zelle750_1.Value, InStr(1, Zelle750_1.Value, "20000 ") - 1)
' Nr750 = Left(Zelle750_1.Value, 17) 'Alternative, wenn Nummer immer gleich lang
'2. Position mit Suchbegriff finden
Set Zelle750_2 = .Find(what:=vFind, LookIn:=xlValues, lookat:=xlPart, _
after:=Zelle750_1, searchorder:=xlByRows, searchdirection:=xlNext)
If Zelle750_2 Is Nothing Then
MsgBox "Kein 2. Element gefunden mit: " & vFind
Exit Sub
ElseIf Zelle750_2.Address = Zelle750_1.Address Then
MsgBox "Kein 2. Element gefunden mit: " & vFind
Exit Sub
Else
'Nummern in den beiden Fundenstellen vergleichen
If Left(Zelle750_2.Value, Len(Nr750)) = Nr750 Then
'1. Position mit 2. Suchbegriff finden
vFind = "0850@"
Set Zelle850_1 = .Find(what:=vFind, LookIn:=xlValues, lookat:=xlPart, _
after:=Zelle750_1, searchorder:=xlByRows, searchdirection:=xlNext)
If Zelle850_1 Is Nothing Then
MsgBox "Kein Element gefunden mit: " & vFind
Else
'2. Position mit 2. Suchbegriff finden
Set Zelle850_2 = .Find(what:=vFind, LookIn:=xlValues, lookat:=xlPart, _
after:=Zelle750_2, searchorder:=xlByRows, searchdirection:=xlNext)
If Zelle850_2 Is Nothing Then
MsgBox "Kein 2. Element gefunden mit: " & vFind
Exit Sub
ElseIf Zelle850_2.Address = Zelle850_1.Address Then
MsgBox "Kein 2. Element gefunden mit: " & vFind
Exit Sub
Else
'1. Fundstelle mit 2. Suchbegriff ausschneiden
Zelle850_1.Cut
'1. Fundstelle mit 2. Suchbegriff vor der 2. Fundstelle einfügen
Zelle850_2.Insert shift:=xlShiftDown
'1. Fundstelle mit 2. Suchbegriff nach der 2. Fundstelle einfügen
' Zelle850_2.Offset(1, 0).Insert shift:=xlShiftDown
End If
End If
Else
MsgBox vFind & "-Nummern sind unterschiedlich!"
End If
End If
End If
End With
End With
End Sub