AW: Das sieht super aus. :-)
14.04.2009 18:28:29
Tino
Hallo,
kann man auch noch einbauen, brauche aber eine zweite Hilfsspalte.
Sub Test()
Dim Bereich As Range, tempZelle As Range
Dim LRow As Long, A As Long
Dim myAr() As String, myAr2() As Long
Set Bereich = Range("E5", Cells(Rows.Count, 5).End(xlUp))
If Intersect(Bereich, Rows("1:4")) Is Nothing Then
Application.ScreenUpdating = False
Set Bereich = Bereich.Offset(0, Columns.Count - Bereich.Column)
LRow = Cells(Rows.Count, 5).End(xlUp).Row
Bereich.FormulaR1C1 = "=IF(AND(SUMPRODUCT((RC5:R" & LRow & "C5=RC5)*(RC7:R" & LRow & "C7=RC7))=1,OR(RC5<>"""",RC5<>"""")),0,"""")"
If Application.WorksheetFunction.CountIfs(Bereich, 0) > 0 Then
For Each tempZelle In Bereich.SpecialCells(xlCellTypeFormulas, 1)
If A = 0 Then
Bereich.FormulaR1C1 = "=SUMPRODUCT((R5C5:R" & LRow & "C5=RC5)*(R5C7:R" & LRow & "C7=RC7))"
End If
Redim Preserve myAr(A)
Redim Preserve myAr2(A)
myAr(A) = Cells(tempZelle.Row, 5) & ":" & Cells(tempZelle.Row, 7) & " X " & tempZelle
myAr2(A) = tempZelle
A = A + 1
Next tempZelle
Columns(Columns.Count).Delete
Cells(1, Columns.Count - 1).Resize(A) = Application.Transpose(myAr)
Cells(1, Columns.Count).Resize(A) = Application.Transpose(myAr2)
Range(Cells(1, Columns.Count - 1), Cells(LRow, Columns.Count)).Sort Cells(1, Columns.Count), 1, , , , , , xlNo
Range("P5", Cells(Rows.Count, 16)).Value = ""
Range(Cells(1, Columns.Count - 1), Cells(Rows.Count, Columns.Count - 1).End(xlUp)).Copy Range("P5")
End If
Columns(Columns.Count).Delete
Columns(Columns.Count - 1).Delete
Application.ScreenUpdating = True
End If
End Sub
Gruß Tino