AW: Matrix Auswertung
02.12.2021 13:28:43
ChrisL
Hi
Mal ein erster Wurf...
Sub t()
Dim rng As Range, lZ As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
.Range("AK2:AM999").ClearContents
For Each rng In .Range("A6:AB41")
If rng "" Then
If WorksheetFunction.CountIf(.Columns(37), rng) = 0 Then
lZ = .Cells(Rows.Count, 37).End(xlUp).Row + 1
.Cells(lZ, 37) = rng
.Cells(lZ, 38) = rng.MergeArea.Cells.Count
.Cells(lZ, 39) = 1
Else
lZ = Application.Match(rng, .Columns(37), 0)
.Cells(lZ, 39) = .Cells(lZ, 39) + 1
End If
End If
Next rng
.Sort.SortFields.Clear
.Sort.SortFields.Add2 Key:=.Range("AK2:AK" & .Cells(Rows.Count, 37).End(xlUp).Row), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SetRange .Range("AK1:AO" & .Cells(Rows.Count, 37).End(xlUp).Row)
.Sort.Header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.Apply
End With
Application.Calculation = xlCalculationAutomatic
End Sub
cu
Chris