Hallo,
ich habe ein Problem. Ich habe eine Datei mit einem großen VBA Skript geschrieben.
Bei einer bestimmten Funktion hatte ich etwas externe Hilfe aber komme nun nicht mehr weiter.
Ich nutze die Daten aus "Rohdaten" und füge diese in "Programm" ein.
Dann drücke ich oben auf "Daten verarbeiten" und diese werden in die Tabelle Ergebnis eingetragen.
Das wichtigste ist: er soll sich die Spalte C ansehen und wenn dort 2 gleiche Werte auftauschen, dann bestimmte Spalten zusammen addieren und andere verschieben.
Das klappt auch soweit. Nur sehr sporadisch (in meinem Beispiel beim 17.11.2021) fügt er plötzlich Zeilen zusammen die gar nicht zusammen gehören.
Mögt ihr da mal gucken? Ich blicke da nicht durch :-(
P.S. Wenn das Skript läuft hängt Excel für ca. 20 Sekunden. Das war aber schon immer so und ist nicht so schlimm.
Nur als Info :-D
Du verlangst ein bissel viel. Obwohl "mal gucken" haben sicher schon Einige getan.
Aber bei der Beschreibung u. diesem Code verlässt Einem schlagartig das Bedürfnis sich dem anzunehmen.
Der Knackpunkt ist aber das du nicht sagst was genau!!!! denn nicht zusammen passt. Wie sind denn die Bedingungen damit die richtigen Dinge passieren? Und was wird hier nicht richtig zusammen gezogen?
Weist du eigentlich wieviel Zeit es benötigt, um dieses Machwerk zu studieren? Und dann soll man mal eben mit dem Finger drauf zeigen wo der Fehler ist.
Nee, das geht nicht.
Du mußt schon mehr Klarheit in die Sache bringen. Markiere die falschen Datensätze für Helfer.
Und wenn du als Kommentar im Code hinterlegst was das eine oder Andere so tun soll, findet sich sicher auch eine schnelle Möglichkeit.
Tip: select und activate sind meist überflüssig. nutze Option Explicit, deklariere Variablen im Kopfbereich von Subs und functions
Entschuldigung für die späte Antwort.
Habe den betroffenen Bereich in der Programm-Datei markiert.
Es tauschen öfter 2x Zeilen auf die in der Spalte C einen identischen Wert besitzen. z.B. 830.
Dann soll er die Spalten E-F in der Zeile addieren und X und Y 1x hochschieben.
Das macht das Skript auch. Nur manchmal addiert es plötzlich 2,3,4 Zeilen die NICHT in C identisch sind und ich verstehe nicht warum.
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
Hallo,
danke erstmal für den Denk-Anstoß.
Leider kommt immer bei folgender Stelle ( If oRng.Cells(1).Value = "" Then )
der Fehler: Laufzeitfehler 91 = Objektvariable oder With-Blockvariable nicht festgelegt.
Hallo,
du suchst nach einer Schnittmenge ... kann es sein, dass diese eventuell leer ist ?
Vielleicht einfach mal darauf prüfen ?
Code:
Set oRng = Intersect(Sheets(2).UsedRange, Sheets(2).Rows(lloTarget))
If Not oRng Is Nothing Then
If oRng.Cells(1).Value = "" Then
'...
End If