AW: Werte übertragen von Zeile in Spalte
31.03.2015 08:55:39
Gregor
Hallo
Das ist ein funktionierender Code, nur leider recht langsam. Evt. kann mir ein vba-Profi diesen prüfen und ergänzen/ändern, damit dieser schneller läuft.
Option Explicit
Sub Dict_Max()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim myDict As Object, arW, Zeile As Long, Zeile_Ziel As Long, strK As String, i As Long, Hö _
he As Long
Dim arrK, arE(), arrDaten()
Dim Länge As Double, Start As Double, Start1 As Double, Spalte As Double
Dim P As Variant, H As Variant, Wert As Variant
Dim a As Variant
Set myDict = CreateObject("Scripting.Dictionary")
With Sheets("Quelle")
arW = .Cells(2, 1).Resize(.Cells(.Rows.Count, 2).End(xlUp).Row - 1, 18)
End With
For Zeile = 1 To UBound(arW)
If arW(Zeile, 1) = "" Then arW(Zeile, 1) = arW(Zeile - 1, 1)
strK = arW(Zeile, 1) & "|" & arW(Zeile, 3)
If myDict.Exists(strK) Then
'neuer Wert ist grösser
If myDict(strK) > Int(arW(Zeile, 2)) Then
GoTo weiter
End If
Else
myDict(strK) = Int(arW(Zeile, 2))
End If
ReDim arrDaten(1 To 17, 1 To UBound(arW))
Spalte = 0
arrDaten(1, 1) = myDict(strK)
arrDaten(17, 1) = 0
For Start = 0 To 6
P = Array("P55", "P45", "P40", "P35", "P30", "P25", "P20")
Spalte = Spalte + 2
If arW(Zeile, 4) = P(Start) Then
arrDaten(Spalte, 1) = Int(arW(Zeile, 6))
arrDaten(Spalte + 1, 1) = arW(Zeile, 5)
End If
If arW(Zeile, 7) = P(Start) Then
arrDaten(Spalte, 1) = arrDaten(Spalte, 1) + Int(arW(Zeile, 9))
arrDaten(Spalte + 1, 1) = arW(Zeile, 8)
End If
If arW(Zeile, 10) = P(Start) Then
arrDaten(Spalte, 1) = arrDaten(Spalte, 1) + Int(arW(Zeile, 12))
arrDaten(Spalte + 1, 1) = arW(Zeile, 11)
End If
If arW(Zeile, 13) = P(Start) Then
arrDaten(Spalte, 1) = arrDaten(Spalte, 1) + Int(arW(Zeile, 15))
arrDaten(Spalte + 1, 1) = arW(Zeile, 14)
End If
If arW(Zeile, 16) = P(Start) Then
arrDaten(Spalte, 1) = arrDaten(Spalte, 1) + Int(arW(Zeile, 18))
arrDaten(Spalte + 1, 1) = arW(Zeile, 17)
End If
Next Start
For Start1 = 4 To 16 Step 3
If arW(Zeile, Start1) = "P19" Or arW(Zeile, Start1) = "P18" Or arW(Zeile, Start1) = _
"P17" Or arW(Zeile, Start1) = "P16" Or arW(Zeile, Start1) = "P15" _
Or arW(Zeile, Start1) = "P14" Or arW(Zeile, Start1) = "P13" Or arW(Zeile, _
Start1) = "P12" Or arW(Zeile, Start1) = "P11" Or arW(Zeile, Start1) = "P10" Then
Höhe = Right(arW(Zeile, Start1), 2)
arrDaten(16, 1) = Höhe
If arrDaten(16, 1) <> "" And arrDaten(16, 1) > Höhe Then arrDaten(16, 1) = Höhe
arrDaten(17, 1) = arrDaten(17, 1) + Int(arW(Zeile, Start1 + 2))
End If
Next Start1
If arrDaten(17, 1) = 0 Then arrDaten(17, 1) = ""
With Sheets("Ziel")
On Error Resume Next
Zeile_Ziel = .Application.Match(arW(Zeile, 1), .Columns(1), 0)
For i = Zeile_Ziel To Zeile_Ziel + 30
If .Cells(i, 2) = arW(Zeile, 3) Then
.Cells(i, 3).Resize(1, 17) = WorksheetFunction.Transpose(arrDaten)
Exit For
End If
Next i
End With
weiter:
Next Zeile
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Vielen Dank
Gregor