Zeilen zusammenführen mit VBA

[mrschumacker]

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

[mrschumacker]

Keiner eine Idee? :-(

[ralf_b]

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

[mrschumacker]

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.

[ralf_b]

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

[mrschumacker]

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.

[Flotter Feger]

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