AW: Extrem große Datenmengen verarbeiten und zuordnen
18.11.2014 16:53:38
fcs
Hallo Barry,
hier mal ein Ansatz. Ich bin mir aber aber nicht sicher, ob ich die Verarbeitung der Einzelrollen korrekt verstanden hab. Im Moment werden sie ignoriert.
Gruß
Franz
'Erstellt unter Excel 2010
'Code in einem allgemeinen Modul
Sub TA_Sortieren_extrahieren()
' Sortieren Makro
Dim wksData As Worksheet, wksErgebnis As Worksheet
Dim Zeile_D As Long, Zeile_D1 As Long, Zeile_DL As Long, Spalte_DL As Long
Dim arrData, arrErgebnis, iCount As Integer, iCount2 As Long, Spalte
Dim strRolle As String, strTA As String
Set wksData = ActiveWorkbook.Worksheets("Daten")
Set wksErgebnis = ActiveWorkbook.Worksheets("Ergebnis")
With wksData
'Daten sortieren nach Role Type / Tellenname / TA
If .AutoFilterMode = True Then
If .FilterMode = True Then .ShowAllData
Else
.UsedRange.AutoFilter
End If
.AutoFilter.Sort.SortFields.Clear
.AutoFilter.Sort.SortFields.Add Key:=.Range("D2"), _
SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
.AutoFilter.Sort.SortFields.Add Key:=.Range("C2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
.AutoFilter.Sort.SortFields.Add Key:=.Range("E2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'letzte Daten-Zeile ermitteln
Zeile_DL = .Cells(.Rows.Count, 1).End(xlUp).Row
'letzte Daten-Spalte setzen/berechnen
Spalte_DL = 9 ' .Cells(1, .Columns.Count).End(xlToLeft).Column
'Daten in Array einlesen
arrData = .Range(.Cells(1, 1), .Cells(Zeile_DL, Spalte_DL + 1))
'Titelzeile als zu übernehmen kennzeichnen
arrData(1, Spalte_DL + 1) = True: iCount2 = 1
For Zeile_D = 2 To Zeile_DL
'Prüfen, ob Zeile schon mit True oder False gekennzeichnet wurde
If IsEmpty(arrData(Zeile_D, Spalte_DL + 1)) Then
'Rollenname in Variable einlesen, wenn er wechselt
If strRolle arrData(Zeile_D, 3) Then
strRolle = arrData(Zeile_D, 3)
End If
'Prüfen, ob Sammelrolle
If arrData(Zeile_D, 4) = "Sammelrolle" Then
'TA in Variable einlesen
strTA = arrData(Zeile_D, 5)
'Zähler auf 1 setzen
iCount = 1
'Liste bis zum Ende abarbeiten
For Zeile_D1 = Zeile_D + 1 To Zeile_DL
'Prüfen, ob TA übereinstimmt
If arrData(Zeile_D1, 5) = strTA Then
'Prüfen, ob Sammelrolle
If arrData(Zeile_D1, 4) = "Sammelrolle" Then
'Prüfen, ob Rollenname verschieden
If arrData(Zeile_D1, 3) strRolle Then
iCount = iCount + 1
arrData(Zeile_D, Spalte_DL + 1) = False
End If
End If
End If
Next Zeile_D1
If iCount = 1 Then
'TA kommt nur einmal vor
arrData(Zeile_D, Spalte_DL + 1) = True: iCount2 = iCount2 + 1
Else
arrData(Zeile_D, Spalte_DL + 1) = False
End If
iCount = 0
Else
'Einzelrollen
arrData(Zeile_D, Spalte_DL + 1) = False ': iCount2 = iCount2 + 1
End If
End If
Next Zeile_D
End With 'wksData
'Ergebnis-Array dimensionieren
ReDim arrErgebnis(1 To iCount2, 1 To Spalte_DL)
iCount2 = 0
'Alle mit True markierten Zeilen ins ErgebnisArray übernehmen
For Zeile_D = 1 To Zeile_DL
If arrData(Zeile_D, Spalte_DL + 1) = True Then
iCount2 = iCount2 + 1
For Spalte = 1 To Spalte_DL
arrErgebnis(iCount2, Spalte) = arrData(Zeile_D, Spalte)
Next
End If
Next Zeile_D
Application.ScreenUpdating = False
With wksErgebnis
'Inhalte löschen
.UsedRange.ClearContents
'Ergebnis-Array eintragen
.Cells(1, 1).Resize(iCount2, Spalte_DL) = arrErgebnis
End With
Application.ScreenUpdating = True
Erase arrErgebnis, arrData
End Sub