Ruuuuddddiiii =)
07.06.2013 10:45:41
Jackd
Vielen DAnk nochmal für deine bisherige unterstützung
Es funktioniert für die eine Aufgabenstellung auch super.
Nur Wollte ich das jetzt auf eine andere Mappe anpassen, bei der "fast" das gleiche Problem ist, mit einer Ausnahme, dass kein Erstauftrag oder Folgeauftrag gefordert ist.
Und ich bekomm es nicht hin.
Das "Problem ist analog" ich habe eine Kundennummer und verschiedene Aufträge (ohne klassifizierung)
Könntest du mir bitte nochmals helfend unter die Arme greifen
Sub Sortiersub()
Dim rngOPS, arrOPS
Set rngOPS = Range(Cells(2, 1), Cells(Rows.Count, 4).End(xlUp))
'Funktionsaufruf
arrOPS = ops(rngOPS)
'Tabelle Leeren
'Cells.Clear
' Array Eintragen
Cells(5, 12).Resize(UBound(arrOPS), UBound(arrOps, 2)) = arrOPS
End Sub
Function ops(ByVal rngA As Range)
Dim objKD As Object
Dim rngC As Range
Dim i As Integer, j As Integer, iMax As Integer
Dim arrTmp, arrItems, arrNeu()
Set objKD = CreateObject("Scripting.dictionary") 'Datensammler
For Each rngC In rngA.Columns(4).Cells '(Patienten ID)
If objKD .exists(rngC.Value) Then
arrTmp = objKD (rngC.Value)
ReDim arrNeu(UBound(arrTmp) + 1)
For i = 0 To UBound(arrTmp)
arrNeu(i) = arrTmp(i)
Next
objKD (rngC.Value) = arrNeu
iMax = WorksheetFunction.Max(iMax, UBound(arrNeu))
Else 'neuer Patient
objKD (rngC.Value) = Array(rngC.Offset(, -3), rngC.Offset(, -2), rngC.Offset(, -1), _
rngC.Value, _
rngC.Offset(, 1).Value, rngC.Offset(, 2).Value, rngC.Offset(, 3).Value, , , _
rngC.Offset(, 7).Value, rngC.Offset(, 6).Value)
iMax = WorksheetFunction.Max(iMax, 2)
End If
Next rngC
arrItems = objKD .items
ReDim arrNeu(1 To UBound(arrItems) + 2, 1 To iMax + 1)
'Überschriften
arrNeu(1, 1) = "IK"
arrNeu(1, 2) = "Standort"
arrNeu(1, 3) = "Bereich"
arrNeu(1, 4) = "internes-Kennzeichen"
arrNeu(1, 5) = "Version"
'arrNeu(1, 6) = "Kode"
'arrNeu(1, 7) = "Lokalisation"
'arrNeu(1, 8) = "Datum"
'arrNeu(1, 9) = "PErson1"
'arrNeu(1, 10) = "Person2"
For i = 7 To UBound(arrNeu, 2)
arrNeu(1, i) = "OPS " & i - 6
Next
'Daten in Array schreiben
For i = 0 To UBound(arrItems)
arrTmp = arrItems(i)
For j = 0 To UBound(arrTmp)
arrNeu(i + 2, j + 1) = arrTmp(j)
Next
Next
ops = arrNeu
End Function
Zudem ist mir nicht klar, warum der einen Fehler bringt, wenn ich den rngOPS setze und die Spaltenanzahl erhöhe (der DAtensatz hat eigentlich mehr Spalten als 4 ) bringt er nen Indexfehler
Funktioniert aber in der Ursprünglichen Problemstellung
Ratlose Grüße
Und Thanks in advance