20.01.2022, 00:19
ich weis immer noch nicht was dieses Array für eine Funktion hat. ICh habe deshalb deine Code etwas umgebaut, in der Hoffnung das du den Fehler dann besser findest. Ist ja deine Anwendung und du mußt ja wissen was da passieren soll und was da nicht passieren soll.
Code:
Sub MasterMakro()
Dim myZeilenA As Long, lloRow As Long, cnt As Long, lloTarget As Long, lloCol As Long
Dim larMerge(), liIdx As Integer, lboExist As Boolean
Dim larSplit, liIdxSpl As Integer
Dim oRng As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Worksheets("Daten") 'Tabelle Daten aktivieren
.Range("E1") = "MaxNrValue" 'Variable als Text einfügen
.Range("D1").Value = WorksheetFunction.Count("C:C") 'Menge der Zahlen in Feld C zählen -3
MaxNrValue = .Range("D1").Value 'Menge der Zahlen in C als Variable speichern
MaxNrValue = MaxNrValue + 5 '5 hinzu addieren
ReDim larMerge(0)
'schleife über alle zeilen mit werten in "DATEN"
For myZeilenA = 6 To .UsedRange.SpecialCells(xlCellTypeLastCell).Row
'"A" wegkürzen
Select Case Left(.Cells(myZeilenA, 3), 1)
Case "A": .Cells(myZeilenA, 3) = Left(.Cells(myZeilenA, 3), 4)
Case "M"
With Intersect(.UsedRange, .Rows(myZeilen)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Case Else
If .Cells(myZeilenA, 3).Value Like "Su. Liefertag (*)" Then 'SU..." ersetzen
.Cells(myZeilenA, 1).Resize(, .UsedRange.Columns.Count).Value = Sheets("Ergebnis").Range("A4:A" & .UsedRange.Columns.Count).Value
End If
End Select
'Array bearbeitung
For liIdx = 0 To UBound(larMerge)
If InStr(larMerge(liIdx), .Range("C" & myZeilenA).Value) > 0 Then
lboExist = True
Exit For
End If
Next
If lboExist = True Then
lboExist = False
larMerge(UBound(larMerge) - 1) = larMerge(UBound(larMerge) - 1) & ";" & myZeilenA
Else
'!!!Hier wird die Spalte C betrachtet!!!
'wert aus C und ";" und Zeilennummer in Array
larMerge(UBound(larMerge)) = .Range("C" & myZeilenA).Value & ";" & myZeilenA
'Array vergrößern
ReDim Preserve larMerge(UBound(larMerge) + 1)
End If
Next myZeilenA
'!!!!! Hier beginnt wohl der Fehler
ReDim Preserve larMerge(UBound(larMerge) - 1) 'Array um letzten, leeren Wert verkleinern
lloTarget = 6
'alle belegten Zeilen in Ergebnis werden gelöscht, Wieso?
Sheets(2).Rows("6:" & Sheets(2).Cells(Sheets(2).Rows.Count, 6).End(xlUp).Row).Delete shift:=xlUp
For liIdx = 0 To UBound(larMerge) 'Arraywerte durchlaufen und in Ergebnis einfügen
larSplit = Split(larMerge(liIdx), ";")
For liIdxSpl = 1 To UBound(larSplit)
'Wert aus Array in "cnt" speichern
cnt = larSplit(liIdxSpl)
'aktuelle Zeile in Object "oRng" referenzieren
Set oRng = Intersect(Sheets(2).UsedRange, Sheets(2).Rows(lloTarget))
If oRng.Cells(1).Value = "" Then
oRng.Cells(1).Resize(, 4).Value = .Range("A" & cnt).Resize(, 4).Value
oRng.Cells(20).Resize(, 4).Value = .Range("T" & cnt).Resize(, 4).Value
oRng.Cells(25).Resize(, 3).Value = .Range("Y" & cnt).Resize(, 3).Value
End If
oRng.Cells(26).Value = .Range("X" & cnt).Value 'alt X einen hoch schieben
oRng.Cells(25).Value = .Range("Y" & cnt).Value 'alt Y einen hoch schieben
'Werte in der Zeile nach Ergebniszeile übertragen und einen Wert aus anderer Zelle addieren
For lloCol = 5 To 19
oRng.Cells(lloCol).Value = oRng.Cells(lloCol).Value + .Cells(cnt, lloCol).Value
Next
Next
lloTarget = lloTarget + 1 'Zeilennummer in Ergebnis hochzählen
Next
End With
'!!!!! Hier endet wohl der Fehler
With Worksheets("Ergebnis") 'Tabelle Ergebnis nutzen
'Diese Zeile kopiert die Titelzeile aus der Tabelle Daten nach Ergebnis
Sheets("Daten").Rows(5).Copy Sheets("Ergebnis").Rows(5)
'hier lassen wir den Text in C rechtsbündig darstellen
.Columns("C:C").HorizontalAlignment = xlRight
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Range("A6").Select 'zum Abschluss A6 markieren
ActiveWorkbook.Save 'Datei speichern
End With
End Sub