Schleife läuft endlos.....?

Sub Prfg() Sheets("Import").Activate Dim LoI As Long Dim LoJ As Long Dim LoLetzte1 As Long Dim LoLetzte2 As Long LoLetzte1 = 65536 With Worksheets("Eingabe") If .Range("K65536") = "" Then LoLetzte1 = .Range("K65536").End(xlUp).Row End With LoLetzte2 = 65536 With Worksheets("Import") If .Range("I65536") = "" Then LoLetzte2 = .Range("I65536").End(xlUp).Row End With For LoI = 6 To LoLetzte1 For LoJ = 2 To LoLetzte2 If Worksheets("Import").Cells(LoJ, 9) = Worksheets("Eingabe").Cells(LoI, 10) _ Or Worksheets("Import").Cells(LoJ, 8).Value = 378000 Then '1 schreiben wenn ok Worksheets("Import").Cells(LoJ, 18).Value = 1 Else 'Fehlerzeile kopieren nach Fehlerprotokoll 'xxxxxxxxxxxxxxxxxxxxxxxxx hier hängt die Kiste xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx Rows(LoJ).Copy Sheets("Fehlerprotokoll").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0). _ PasteSpecial xlPasteValues 'xxxxxxxxxxxxxxxxxxxxxxxxx hier hängt die Kiste xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx End If Next LoJ Next LoI 'Summe in Zelle R1 Blatt Import schreiben und Fehlermeldung ausgeben wenn nicht 0 Sheets("Import").Range("R1") = Application.WorksheetFunction.Sum(Range("R2:R10000")) Sheets("Import").Range("S1") = Application.WorksheetFunction.Count(Range("K2:K10000")) 'die erstellen 1sen werden summiert und verglichen: If Sheets("Import").Range("R1").Value = Sheets("Import").Range("S1").Value Then Else 'wenn Fehler gefunden (R1 ist ungleich S1), dann Fehlermeldung MsgBox "....." Sheets("Eingabe").Activate End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

ok Gerd
erstmal danke, dass du dich damit beschäftigst. Du hast recht, Spalte 8 auf dem Blatt Eingabe stimmt nicht, es ist Spalte 10. Es war gestern wohl spät, habe beim schreiben wohl nicht so richtig aufgepasst. Sorry.
Eigentlich ist es sogar Spalte 11 (Spalte K um es mal mit Buchstaben auszudrücken), da ist aber eine ausgeblendete Spalte mit dabei. Offenbar wird die beim zählen aber übergangen, war mir vorher auch noch nicht so klar.
Ich kann dir nicht einfach die Datei hoch laden.
erstens ist das mittlerweile ein ziemliches Monster, da laufen allerlei Prüfroutinen drin ab. Das würde zu unübersichtlich für dich
zweitens leider vertraulich
was ich aber machen kann, ich habe dir einfach mal die 3 Blätter um die es geht in eine neue Datei reinkopiert. Den Code habe ich auch raus gelassen. Es geht ja "nur" dass du sehen kannst was ich vor habe.
https://www.herber.de/bbs/user/108367.xlsx
Das kannst du dir gerne mal anschauen.
nochmal zusammenfassend:

auf Eingabe in Spalte K stehen ab Zeile 6 bis zu zeile ? (unbestimmt) die Kontrollwerte - gelb markiert

in Import Spalte I stehen die Werte, die geprüft werden sollen - auch gelb markiert

taucht in Import in Spalte I ein Wert auf, der nicht in Eingabe Spalte K steht, dann soll auf Fehlerprotokoll kopiert werden

ich verstehe halt nicht, warum er mit die Aktion korrekt macht (also die 1 schreibt in Spalte R) wenn die Werte in Eingabe und Import übereinstimmen - dann aber auch gleichzeitig immer fleißig die Aktion für den Else-Fall ausführt (also kopieren auf Fehlerprotokoll) - dazu habe ich in Zeile 11 mal einen Fehler eingebaut, hier müsste die Aktion also ausgeführt werden.
die "Or-Bedingung" dient nur dazu die Zeilen auf Import abzufangen, in denen in Spalte I gar kein Wert steht. Auch hier soll er die 1 schreiben und nix kopieren. Das habe ich nicht erwähnt um es nicht zu kompliziert zu machen, denn wie gesagt - bei Übereinstimmung funktioniert ja m.E. alles prächtig.
schau mal ob du was damit anfangen kannst...

Also Gerd
ich habe nochmal umgebaut weil ich dachte ich kann den Fehler identifizieren.
Ich habe jetzt einfach mal den "Else-Fall" in eine zweite Schleife gebaut weil ich dachte er hätte mit der Else-Aktion irgendein Problem. Sprich - in der ersten Schleife bei Else nichts machen, nach Durchlauf der Schleife eine neue Schleife starten und die 1sen in Spalte R (Spalte 18) prüfen. Immer wenn keine 1 (Ergebnis aus der ersten Schleife), dann Zeile kopieren. Das würde auf das gleiche hinaus laufen.
Funktioniert aber trotzdem nicht. kurioserweise läuft er das gesamte Blatt Import exakt 2x durch und kopiert alle Zeilen, also auch die mit 1sen. Insofern Änderung zum bisherigen Fehler weil bis dato die Schleife einfach endlos durch lief. Warum jetzt aber exakt 2x erschließt sich mir wieder nicht. Abgesehen davon will ich ja auch nur die "Fehlerzeilen" kopieren.
ich blick nicht mehr durch. Ist die Aktion
Rows(LoJ, 1).Copy die richtige?
Bzw Rows(LoK, 1).Copy in der neuen Schleife
Ich vermute nämlich nach wie vor, dass er zwar die Zeile findet, aber halt nicht die richtige Zeile kopiert....
der umgebaute (und natürlich sehr viel längere) Code:

Sub Prfg()
'da war ein Blattschutz drauf
Call Schutz_Aufheben
Sheets("Import").Activate
Dim LoI As Long
Dim LoJ As Long
Dim LoLetzte1 As Long
Dim LoLetzte2 As Long
LoLetzte1 = 65536
With Worksheets("Eingabe")
If .Range("K65536") = "" Then LoLetzte1 = .Range("K65536").End(xlUp).Row
End With
LoLetzte2 = 65536
With Worksheets("Import")
If .Range("I65536") = "" Then LoLetzte2 = .Range("I65536").End(xlUp).Row
End With
For LoI = 6 To LoLetzte1
For LoJ = 2 To LoLetzte2
If Worksheets("Import").Cells(LoJ, 9) = Worksheets("Eingabe").Cells(LoI, 11) _
Or Worksheets("Import").Cells(LoJ, 8).Value = 378000 Then
'1 schreiben wenn ok
Worksheets("Import").Cells(LoJ, 18).Value = 1
Else
'Fehlerzeile kopieren nach Fehlerprotokoll
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'ich habe das Original hier mal ausgeschaltet, also nichts machen bei Else damit ich unten
'die Schleife dran hängen kann
'                Rows(LoJ).Copy
'                Sheets("Fehlerprotokoll").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0). _
EntireRow _
'                .PasteSpecial xlPasteValues
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End If
Next LoJ
Next LoI
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'hier habe ich die neue Schleife hinten dran gehängt um auf des Pudel's Kern zu kommen
Dim LoK As Long
Dim LoLetzte3 As Long
LoLetzte3 = 65536
With Worksheets("Import")
If .Range("R65536") = "" Then LoLetzte3 = .Range("I65536").End(xlUp).Row
End With
For LoK = 2 To LoLetzte3
If Worksheets("Import").Cells(LoK, 18).Value = 1 Then
Else
Rows(LoK).Copy
Sheets("Fehlerprotokoll").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow  _
_
.PasteSpecial xlPasteValues
End If
Next LoK
'Summe in Zelle R1 Blatt Import schreiben und Fehlermeldung ausgeben wenn nicht identisch mit  _
S1 '(Anzahl befüllter Zeilen)
Sheets("Import").Range("R1") = Application.WorksheetFunction.Sum(Range("R2:R10000"))
Sheets("Import").Range("S1") = Application.WorksheetFunction.Count(Range("F2:F10000"))
If Sheets("Import").Range("R1").Value = Sheets("Import").Range("S1").Value Then
Else
'wenn Fehler gefunden (R1 ist ungleich S1), dann Fehlermeldung
MsgBox "....."
Sheets("Eingabe").Activate
End If
'der Teil hier hatte im bisherigen Code-Schnipsel gefehlt:
'Spalte R und S1 wieder löschen
Sheets("Import").Range("R1:R10000").ClearContents
Sheets("Import").Range("S1").ClearContents
'da war ein Blattschutz drauf
Call Schutz_Anschalten
End Sub

Sub Fehlerprotokoll() Dim adrFibuKonten As String '--- Adresse der zulässigen Konten ermitteln With Sheets("Eingabe") adrFibuKonten = .Range(.Cells(6, 11), .Cells(5, 11).End(xlDown)).Address(1, 1, xlR1C1) End With With Sheets("Import") With .Range("R2:R" & .Cells(.Rows.Count, 1).End(xlUp).Row) '--- Import kennzeichnen .FormulaR1C1 = "=IF(CountIf(Eingabe!" & adrFibuKonten & ",RC9)=0,""x"",1)" .Formula = .Value '--- Fehlerhafte Daten ins Fehlerprotokoll If WorksheetFunction.CountIf(.Cells, "x") > 0 Then Intersect(.Worksheet.Range("A:K"), .SpecialCells(xlCellTypeConstants, 2).EntireRow). _ Copy Sheets("Fehlerprotokoll").Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial _ xlPasteAll End If End With End With End Sub

Beliebteste Forumthreads (12 Monate)

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread