AW: Sportfest optimieren durch Makro?
Uduuh
Hallo,
in ein Modul:
Option Explicit
Sub KlassenErstellen()
Dim objKlassen As Object, oObj
Dim vntDaten, vntOUT, vntTmp, i As Long
Dim strKey As String
Dim wks As Worksheet
Set objKlassen = CreateObject("scripting.dictionary")
vntDaten = Sheets(1).Cells(1, 1).CurrentRegion
For i = 2 To UBound(vntDaten)
objKlassen(vntDaten(i, 1) & "_" & vntDaten(i, 4)) = 0
Next
For i = 2 To UBound(vntDaten)
strKey = vntDaten(i, 1) & "_" & vntDaten(i, 4)
objKlassen(strKey) = objKlassen(strKey) & "|" & vntDaten(i, 2) & "#" & vntDaten(i, 3)
Next
For Each oObj In objKlassen
vntTmp = Split(objKlassen(oObj), "|")
ReDim vntOUT(1 To UBound(vntTmp), 1 To 2)
vntOUT(1, 1) = "Name"
vntOUT(1, 2) = "Vorname"
For i = 2 To UBound(vntTmp)
vntOUT(i, 1) = Split(vntTmp(i), "#")(0)
vntOUT(i, 2) = Split(vntTmp(i), "#")(1)
Next i
On Error Resume Next
Set wks = Worksheets(oObj)
On Error GoTo 0
If wks Is Nothing Then Set wks = Worksheets.Add(after:=Sheets(Sheets.Count))
With wks
.Cells(1, 1) = oObj
.Cells(1, 1).Font.Bold = True
.Cells(3, 1).Resize(UBound(vntOUT), 2) = vntOUT
.Name = oObj
End With
Next oObj
End Sub
Gruß aus'm Pott
Udo