Guten Tag Thorsten, bitte dringend!!!
26.03.2026 17:55:55
philipp
Hallo Thorsten,
danke im Voraus, bitte unbedingt dein Makro ansehen:
Sub zaehlen_Orginal()
Dim larEvalAll() As Variant, larEvalSum() As Variant
Dim liIdxAll As Integer, liIdxSum As Integer, lboExist As Boolean
Dim lloCol As Integer
Dim liYear As Integer, lloRow As Long
Application.DisplayAlerts = False 'deaktiviert
Application.EnableEvents = False 'deaktiviert
Application.Calculation = xlCalculationManual
ReDim larEvalSum(2, 0)
With Sheets("Adressen") 'wenn Blattname nicht Adressen, dann hier anpassen!
larEvalAll = .Range("N3:P" & .Cells(Rows.Count, 14).End(xlUp).Row).Value
End With
For liIdxAll = 1 To UBound(larEvalAll, 1)
If larEvalSum(0, 0) = "" Then
larEvalSum(0, 0) = larEvalAll(liIdxAll, 1)
larEvalSum(1, 0) = larEvalAll(liIdxAll, 3)
larEvalSum(2, 0) = 1
Else
If larEvalSum(0, UBound(larEvalSum, 2)) = larEvalAll(liIdxAll, 1) And _
larEvalSum(1, UBound(larEvalSum, 2)) = larEvalAll(liIdxAll, 3) Then
larEvalSum(2, UBound(larEvalSum, 2)) = larEvalSum(2, UBound(larEvalSum, 2)) + 1
Else
ReDim Preserve larEvalSum(2, UBound(larEvalSum, 2) + 1)
larEvalSum(0, UBound(larEvalSum, 2)) = larEvalAll(liIdxAll, 1)
larEvalSum(1, UBound(larEvalSum, 2)) = larEvalAll(liIdxAll, 3)
larEvalSum(2, UBound(larEvalSum, 2)) = 1
End If
End If
Next
With Sheets("Rg_Eingang_Tag") 'wenn Blattname nicht Rg_Eingang_Tag, dann hier anpassen!
For lloCol = 3 To 60 Step 5
.Range(.Cells(4, lloCol), .Cells(34, lloCol + 2)).ClearContents
Next
For liYear = 1 To 12
If liYear = 1 Then
lloCol = 2
Else
lloCol = lloCol + 5
End If
For lloRow = 4 To 34 '.Cells(Rows.Count, lloCol).End(xlUp).Row
For liIdxSum = 0 To UBound(larEvalSum, 2)
'bleibt hier stehen: If CDate(.Cells(lloRow, lloCol).Value & .Range("F2").Value) = larEvalSum(0, liIdxSum) Then
Select Case LCase(larEvalSum(1, liIdxSum)) 'damit müssen die buchstaben klein
' Case "ma"
' .Cells(lloRow, lloCol + 1).Value = larEvalSum(2, liIdxSum)
' Case "slk"
' .Cells(lloRow, lloCol + 2).Value = larEvalSum(2, liIdxSum)
' Case "pak"
' .Cells(lloRow, lloCol + 3).Value = larEvalSum(2, liIdxSum)
Case "mg"
.Cells(lloRow, lloCol + 1).Value = .Cells(lloRow, lloCol + 1).Value + larEvalSum(2, liIdxSum)
Case "pau"
.Cells(lloRow, lloCol + 2).Value = .Cells(lloRow, lloCol + 2).Value + larEvalSum(2, liIdxSum)
Case "slo"
.Cells(lloRow, lloCol + 3).Value = .Cells(lloRow, lloCol + 3).Value + larEvalSum(2, liIdxSum)
End Select
End If
Next
Next
Next
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Range("i39").Select
End Sub
ich habe die Zeile makiert, ich nutze DEIN Makro, zahlen werden bis März eingelesen bleibt aber dann stehen.
Bitte schauen,
mfg phil
