AW: überflüssige zeilen löschen
27.06.2007 14:58:08
Peter
Hallo Michael,
der beigefügte Code ist zwar lang und sicher nicht professionel, aber er funktioniert (bei mir zumindest).
Versuch's mal.
Sub Sortierkriterium()
Columns("C:C").Select
Selection.UnMerge
Range("A1:B1500").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("C1").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISBLANK(RC[-2]),"""",IF(LEFT(RC[-1],6)LEFT(R[1]C[-1],6),LEFT(RC[-1],6)&5,IF( _
RIGHT(R[1]C,1)=""5"",(LEFT(RC[-1],6)&4),IF(RIGHT(R[1]C,1)=""4"",(LEFT(RC[-1],6)&3),IF(RIGHT(R[1]C,1)=""3"",(LEFT(RC[-1],6)&2),IF(RIGHT(R[1]C,1)=""2"",(LEFT(RC[-1],6)&1),""DEL""))))))"
Selection.Copy
Range("C1:C1500").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1:C1500").Select
Selection.Sort Key1:=Range("C1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("C1").Activate
Cells.Find(What:="DEL", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False).Activate
ActiveCell.Offset(0, -2).Range("A1:C1500 ").Select
ActiveCell.Activate
Selection.EntireRow.Delete
Range("A1:C1500").Select
Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Cells.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1:B1").Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=LINKS($B2;6)LINKS($B1;6)"
With Selection.FormatConditions(1).Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=LINKS($B2;6)LINKS($B1;6)"
With Selection.FormatConditions(1).Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="0"
Selection.FormatConditions(2).Interior.Pattern = xlNone
Selection.Copy
Range("A2:B1500").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
End Sub