Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 18:41:19
vba Zeilen duplizieren ab aktiver Zeile bis letzte Zeile
25.04.2024 18:22:55
Zeilen mit bestimmtem Datum in andere Mappe übertragen
25.04.2024 18:14:45
VBA - Excell - Kopie und "Diebstahl" Schützen
25.04.2024 17:49:39
Bedingte Formatierung
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1760to1764
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1760to1764
1760to1764
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Makro stürzt ab

Makro stürzt ab
25.05.2020 19:25:07
Archeangelos
Hallo zusammen,
Ich hab im Rahmen meiner Bachelorthesis ein relativ aufwändiges Makro geschrieben.
Das Makro ist mit einer For-Schleife in 3 Teile aufgeteilt ( Eintragung in Spalte A,B,C)..
Das Makro läuft wenn ich es in Teilen (for k = 1 to 2 , oder k = 2 to 3) teste ohne Probleme. Wenn ich aber das gesamte Programm (k = 1 to 3) starte stürzt es nach einer gewissen zeit ab.
Im Anhang ist der Quellcode in dem das Makro abstürzt, wo es genau abstürzt kann ich nicht sagen.
Ich kann leider keine testmappe oder ein testfile hochladen das ich es nicht reprodiziert bekomme.
Ich hoffe ihr könnt beim durschauen des codes ein paar fehlermöglichkeiten aufzählen, ich hab langsam keine ideen mehr.
Das Makro wird durch ein anderes Makro aufgerufen welches vorher die Events, screenupdate und autosave ausschaltet und danach wieder einschaltet:
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
ActiveWorkbook.AutoSaveOn = False
End With
Vielen dank im Vorraus,
Grüße Archeangelos
Quellcode:

Sub QEV_Nummern_eintragen()
If Not ThisWorkbook.Name = "Datenbank_V_016.xlsm" Then
Workbooks("Datenbank_V_016.xlsm").Activate
End If
Dim wks_db As Worksheet
Set wks_db = ThisWorkbook.Sheets("Datenbank_HSN")
Dim wks_dbi As Worksheet
Set wks_dbi = ThisWorkbook.Sheets("QEV_Import")
'Home PC
Workbooks.Open Filename:="dateipfad"
Dim wks_mdb As Worksheet
Set wks_mdb = Workbooks("WERKSTOFFLISTE_2020-04.xlsx").Sheets("CAD-Werkstoffliste  2020-03") _
_
_
Dim k As Integer
For k = 1 To 3
If wks_db.FilterMode Then wks_db.ShowAllData
If k = 1 Then
Materialspalte_DB = 1
QEV_Spalte_DB = 2
wks_db.Activate
Datenbank_Count = WorksheetFunction.CountA(Range("A:A")) - 2
ElseIf k = 2 Then
Materialspalte_DB = 6
QEV_Spalte_DB = 7
wks_db.Activate
Datenbank_Count = WorksheetFunction.CountA(Range("F:F")) - 2
ElseIf k = 3 Then
Materialspalte_DB = 11
QEV_Spalte_DB = 12
wks_db.Activate
Datenbank_Count = WorksheetFunction.CountA(Range("A:A")) - 2
End If
For i = 1 To Datenbank_Count + 1
If Not wks_db.Cells(i + 1, Materialspalte_DB).Value = "" Then
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value & " *"
suchbegriff_bind = wks_db.Cells(i + 1, Materialspalte_DB).Value & "-*"
If InStr(1, suchbegriff_leer, "DBL") = 1 Then
suchbegriff_leer = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value
suchbegriff_bind = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value & "*"
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=10, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
Else
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
End If
wks_mdb.Activate
If wks_mdb.Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells( _
xlCellTypeVisible).Count > 3 Then
wks_mdb.Range("B5:B" & wks_mdb.UsedRange.Rows.Count).SpecialCells( _
xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,  _
SkipBlanks:=False, Transpose:=False
End If
QEV_count = WorksheetFunction.CountA(Range("A:A"))
If QEV_count  1000 Then
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value
wks_dbi.Activate
wks_dbi.Range(Cells(1, 1), Cells(Columns.Count, 112)).ClearContents
If wks_mdb.FilterMode Then wks_mdb.ShowAllData
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:= _
suchbegriff_leer, Operator:=xlAnd
wks_mdb.Activate
If wks_mdb.Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(  _
_
_
xlCellTypeVisible).Count > 3 Then
wks_mdb.Range("B5:B" & wks_mdb.UsedRange.Rows.Count).SpecialCells( _
xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End If
QEV_count = WorksheetFunction.CountA(Range("A:A"))
End If
If Not QEV_count > 1000 Or QEV_count

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro stürzt ab
25.05.2020 23:00:04
Archeangelos
OK ich habe jetzt nochmal einiges geändert und bekomme nun konstant statt einem absturz den Laufzeitfehler '- 21474717848 (80010108) bei dem Befehl
wks_mdb.Range("$A$4:$S$5609").Autofilter Field:=8, Criteria1:=suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
Hier das bild:
Userbild
der aktualisierte Code hier:
Sub QEV_Nummern_eintragen()
If Not ThisWorkbook.Name = "Datenbank_V_016.xlsm" Then
Workbooks("Datenbank_V_016.xlsm").Activate
End If
Dim wks_db As Worksheet
Set wks_db = ThisWorkbook.Sheets("Datenbank_HSN")
Dim wks_dbi As Worksheet
Set wks_dbi = ThisWorkbook.Sheets("QEV_Import")
Workbooks.Open Filename:="C..."Dateipfad"...WERKSTOFFLISTE_2020-04.xlsx"
Dim wks_mdb As Worksheet
Set wks_mdb = Workbooks("WERKSTOFFLISTE_2020-04.xlsx").Sheets("CAD-Werkstoffliste  2020-03") _
Dim k As Integer
For k = 1 To 3
If wks_db.FilterMode Then wks_db.ShowAllData
If k = 1 Then
Materialspalte_DB = 1
QEV_Spalte_DB = 2
wks_db.Activate
Datenbank_Count = WorksheetFunction.CountA(Range("A:A")) - 2
ElseIf k = 2 Then
Materialspalte_DB = 6
QEV_Spalte_DB = 7
wks_db.Activate
Datenbank_Count = WorksheetFunction.CountA(Range("F:F")) - 2
ElseIf k = 3 Then
Materialspalte_DB = 11
QEV_Spalte_DB = 12
wks_db.Activate
Datenbank_Count = WorksheetFunction.CountA(Range("A:A")) - 2
End If
For i = 1 To Datenbank_Count + 1
wks_db.Activate
If Not wks_db.Cells(i + 1, Materialspalte_DB).Value = "" Then
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value & " *"
suchbegriff_bind = wks_db.Cells(i + 1, Materialspalte_DB).Value & "-*"
If InStr(1, suchbegriff_leer, "DBL") = 1 Then
suchbegriff_leer = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value
suchbegriff_bind = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value & "*"
wks_mdb.Activate
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=10, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
Else
wks_mdb.Activate
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
End If
wks_mdb.Activate
If wks_mdb.Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells( _
xlCellTypeVisible).Count > 3 Then
Anzahl_QEV_Nummern = wks_mdb.Range("B1:B" & Cells(Rows.Count, 2).End(xlUp). _
Row).SpecialCells(xlCellTypeVisible).Count - 3
wks_mdb.Range("B5:B" & wks_mdb.UsedRange.Rows.Count).SpecialCells( _
xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,  _
SkipBlanks:=False, Transpose:=False
Else
wks_db.Activate
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value
wks_mdb.Activate
If wks_mdb.FilterMode Then wks_mdb.ShowAllData
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:= _
suchbegriff_leer, Operator:=xlAnd
If wks_mdb.Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells( _
xlCellTypeVisible).Count > 3 Then
Anzahl_QEV_Nummern = wks_mdb.Range("B1:B" & Cells(Rows.Count, 2).End( _
xlUp).Row).SpecialCells(xlCellTypeVisible).Count - 3
wks_mdb.Range("B5:B" & wks_mdb.UsedRange.Rows.Count).SpecialCells( _
xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End If
End If
If Anzahl_QEV_Nummern > 0 Then
wks_db.Activate
wks_db.Cells(i + 1, QEV_Spalte_DB).Clear
wks_db.Cells(i + 1, QEV_Spalte_DB).Value = wks_dbi.Cells(1, 1).Value
For j = 1 To Anzahl_QEV_Nummern
wks_db.Cells(i + 1, QEV_Spalte_DB).Value = wks_db.Cells(i + 1,  _
QEV_Spalte_DB).Value & ", " & wks_dbi.Cells(1 + j, 1).Value
Next j
End If
wks_dbi.Activate
wks_dbi.Range(Cells(1, 1), Cells(Columns.Count, 112)).ClearContents
Suchbegriff = ""
Eintragung = False
wks_mdb.Activate
If wks_mdb.FilterMode Then wks_mdb.ShowAllData
End If
Next i
'Application.Wait (Now + TimeValue("00:00:01"))
Next k
'Workbooks("WERKSTOFFLISTE_2020-04.xlsx").Close SaveChanges:=False
End Sub

Anzeige
AW: Makro stürzt ab
26.05.2020 01:01:30
fcs
Hallo Archangelos,
Code blind zu analysieren ist nicht einfach.
Wenn der Code ohne das "drumherum" funktioniert.
Dann ist möglicherweise de aktuelle Zustand von Excel und seinen Arbeitsmappen die Ursache für den Absturz.
Aufgefallen ist mir:
1. du arbeitst mit dem aktivieren von Tabellenblättern. das macht die Fehlersuche ggf. schwierig, da nicht immer klar ist, in welchem Tabellenblatt das Makro gerade arbeitet/arbeiten soll.
2. Besser ist es konsequent mit vollständigen Verweisen zu den Tabellenblättern zu arbeiten wenn Anweisungen Range- oder Cells-Objekte enthalten.
Die entsprechenden Tabellen-Objekt-Variablen hast du ja alle angelegt und ihnen Blätter zugewiesen.
Wenn dies umgesetzt ist, dann können die Activate-Anweisungen entfallen.
3. Zeilen QEV_count = WorksheetFunction.CountA(Range("A:A"))
Abhäng von der If-Prüfung in den Zeilen oberhalb wird hier in unterschiedlichen Blättern der Wert ermittelt. Hier ggf. das Blatt explizit vorgeben oder die If-Anweisungen optimieren.
4. Du hast nicht alle verwendeten Variablen deklariert - oder stehen die Deklarationen wounders als Public oder Privat im Modul?
Ich hab mal -ohne Garantie- versucht dein Makro anzupassen, um die Referenzen der Range-/Cells-Objekte vollständig anzugeben.
Bei fragwürden Anweisungen hab ich kommentare eingefügt.
LG
Franz 
Sub Test()
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
ActiveWorkbook.AutoSaveOn = False 'Welches Workbook soll hier nicht mehr _
automatisch gespeichert Werden?
End With
Call QEV_Nummern_eintragen
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
ActiveWorkbook.AutoSaveOn = True   '?
End With
End Sub
Sub QEV_Nummern_eintragen()
Dim wks_db As Worksheet
Dim wks_dbi As Worksheet
Dim wks_mdb As Worksheet
Dim k As Integer, i As Long, j As Long
Dim suchbegriff_leer As String
Dim suchbegriff_bind As String
Dim QEV_count As Long
Dim Materialspalte_DB As Long
Dim QEV_Spalte_DB As Long
Dim Datenbank_Count As Long
'Die folgende Anweisung verstehe ich nicht.
'ThisWorkbook ist die Arbeitsmappe mit den Makros. Sinn würde köchstens machen, _
wenn ActiveWorkbook auf den Namen geprüft wird.
If Not ThisWorkbook.Name = "Datenbank_V_016.xlsm" Then
Workbooks("Datenbank_V_016.xlsm").Activate
End If
Set wks_db = ThisWorkbook.Sheets("Datenbank_HSN")
Set wks_dbi = ThisWorkbook.Sheets("QEV_Import")
'Home PC
Workbooks.Open Filename:="dateipfad"    '?   Funktioniert das ?
Set wks_mdb = _
Workbooks("WERKSTOFFLISTE_2020-04.xlsx").Sheets("CAD-Werkstoffliste  2020-03")
For k = 1 To 3
With wks_db
If .FilterMode Then .ShowAllData
.Activate
If k = 1 Then
Materialspalte_DB = 1
QEV_Spalte_DB = 2
Datenbank_Count = WorksheetFunction.CountA(.Range("A:A")) - 2
ElseIf k = 2 Then
Materialspalte_DB = 6
QEV_Spalte_DB = 7
Datenbank_Count = WorksheetFunction.CountA(.Range("F:F")) - 2
ElseIf k = 3 Then
Materialspalte_DB = 11
QEV_Spalte_DB = 12
Datenbank_Count = WorksheetFunction.CountA(.Range("A:A")) - 2
End If
End With
For i = 1 To Datenbank_Count + 1
If Not wks_db.Cells(i + 1, Materialspalte_DB).Value = "" Then
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value & " *"
suchbegriff_bind = wks_db.Cells(i + 1, Materialspalte_DB).Value & "-*"
If InStr(1, suchbegriff_leer, "DBL") = 1 Then
suchbegriff_leer = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value
suchbegriff_bind = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value & "*"
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=10, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
Else
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
End If
With wks_mdb
.Activate
If .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row) _
.SpecialCells(xlCellTypeVisible).Count > 3 Then
.Range("B5:B" & .UsedRange.Rows.Count) _
.SpecialCells(xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End With
'in welchem Blatt soll hier gezählt werden ? kann wks_mdb oder wks_dbi sein _
je nach dem Ergebnis der If-Prüfung oberhalb
QEV_count = WorksheetFunction.CountA(Range("A:A"))
If QEV_count  1000 Then
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value
With wks_dbi
.Activate
.Range(.Cells(1, 1), .Cells(.Columns.Count, 112)).ClearContents
End With
With wks_mdb
If .FilterMode Then .ShowAllData
.Activate
.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:= _
suchbegriff_leer, Operator:=xlAnd
If .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row) _
.SpecialCells(xlCellTypeVisible).Count > 3 Then
.Range("B5:B" & wks_mdb.UsedRange.Rows.Count) _
.SpecialCells(xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End With
'in welchem Blatt soll hier gezählt werden ? kann wks_mdb oder wks_dbi sein _
je nach dem Ergebnis der If-Prüfung oberhalb
QEV_count = WorksheetFunction.CountA(Range("A:A"))
End If
If Not QEV_count > 1000 Or QEV_count

Anzeige
AW: Makro stürzt ab
26.05.2020 05:26:32
Archeangelos
Hallo fcs, erstmal vielen dank für die Bemühungen und die Tips für die Übersichtlichkeit,
Ich hab das heute nacht alles mal umgesetzt konnte das Problem aber leider immernoch nicht beheben.
Ich bekomme ich entweder den Laufzeitfehler 21474717848 (80010108) oder Excel stürzt direkt ab , ich weiß leider nicht welche werte i,j,k dabei haben da excel bei dem Laufzeitfehler komplett einfriert und sich nur über den taskmanager beenden lässt.
Zu deinen Fragen über den code:
1. Ich wollte eigentlich ohne das aktivieren von Tabellenblättern, d.h mit vollständigen Verweisen arbeiten allerdings hat das immer wieder zu Fehlermeldungen geführt die durch das vorherige aktivieren des jeweiligen Arbeitsblatt gelöst werden konnten.
2.Zeilen QEV_count war ein Fehler in meiner Programmierung: "Danke für den Hinweis =) , habe ich im neuen Code aber eh anders gelöst
3. Variablendeklaration habe ich nicht durchgehend gehabt, auch da mein Fehler!
4. Activeworkbook.AutoSaveOn : Das ausschalten des Autosaves in wks_db hat den Hintergrund dass ich dadurch ein einfrieren/ abstürzen durch eine zwischenspeicherung während des makrodurchlaufs verhindern wollte
5. Thisworkbook.Name : Mein Fehler, macht mit activeworkbook deutlich mehr sinn! THX
6. workbooks.open : ich habe in dem hier dargestellten code jediglich den tatsächlichen Dateipfad zwecks Datenschutzgründen durch "Dateipfad" ersetzt.
Falls es hilft vielleicht noch als Info: Das Makro muss eine Datei bearbeiten welche ziemlich umfangreich ist.
Daher läuft i bis ca. 3500
für k = 1;2 : j jeweils zw. 3-5
für k = 3 : j jeweils zw. 0-2
Das Makro stürzt in der Regel erst bei K = 2 und i > 2500 ab.
Ich geh dann jetzt mal schlafen und hoffe morgen ein Lösung zu finden.
Gute Nacht, und Grüße
Archeangelos
Den geänderten Quellcode hab ich hier:
Sub QEV_Nummern_eintragen()
Dim wks_db As Worksheet
Dim wks_dbi As Worksheet
Dim wks_mdb As Worksheet
Dim k As Integer, i As Long, j As Long
Dim suchbegriff_leer As String
Dim suchbegriff_bind As String
Dim QEV_count As Long
Dim Materialspalte_DB As Long
Dim QEV_Spalte_DB As Long
Dim Datenbank_Count As Long
If Not ActiveWorkbook.Name = "Datenbank_V_017.xlsm" Then
Workbooks("Datenbank_V_017.xlsm").Activate
End If
Set wks_db = ThisWorkbook.Sheets("Datenbank_HSN")
Set wks_dbi = ThisWorkbook.Sheets("QEV_Import")
'Home PC
Workbooks.Open Filename:="Dateipfad"\WERKSTOFFLISTE_2020-04.xlsx"
Set wks_mdb = _
Workbooks("WERKSTOFFLISTE_2020-04.xlsx").Sheets("CAD-Werkstoffliste  2020-03")
For k = 1 To 3
With wks_db
If .FilterMode Then .ShowAllData
.Activate
If k = 1 Then
Materialspalte_DB = 1
QEV_Spalte_DB = 2
Datenbank_Count = WorksheetFunction.CountA(.Range("A:A")) - 2
ElseIf k = 2 Then
Materialspalte_DB = 6
QEV_Spalte_DB = 7
Datenbank_Count = WorksheetFunction.CountA(.Range("F:F")) - 2
ElseIf k = 3 Then
Materialspalte_DB = 11
QEV_Spalte_DB = 12
Datenbank_Count = WorksheetFunction.CountA(.Range("A:A")) - 2
End If
End With
For i = 1 To Datenbank_Count + 1
Eintragung = False
If Not wks_db.Cells(i + 1, Materialspalte_DB).Value = "" Then
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value & " *"
suchbegriff_bind = wks_db.Cells(i + 1, Materialspalte_DB).Value & "-*"
If InStr(1, suchbegriff_leer, "DBL") = 1 Then
suchbegriff_leer = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value
suchbegriff_bind = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value & "*"
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=10, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
Else
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
End If
With wks_mdb
.Activate
If .Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells( _
xlCellTypeVisible).Count > 3 Then
Eintragung = True
Anzahl_QEV_Nummern = .Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row). _
SpecialCells(xlCellTypeVisible).Count - 3
.Range("B5:B" & wks_mdb.UsedRange.Rows.Count).SpecialCells( _
xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Else
wks_db.Activate
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value
.Activate
If .FilterMode Then .ShowAllData
.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:=suchbegriff_leer, _
Operator:=xlAnd
If .Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells( _
xlCellTypeVisible).Count > 3 Then
Eintragung = True
Anzahl_QEV_Nummern = .Range("B1:B" & Cells(Rows.Count, 2).End(xlUp). _
Row).SpecialCells(xlCellTypeVisible).Count - 3
.Range("B5:B" & wks_mdb.UsedRange.Rows.Count).SpecialCells( _
xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End If
End If
End With
With wks_db
If Eintragung = True Then
.Cells(i + 1, QEV_Spalte_DB).Clear
.Cells(i + 1, QEV_Spalte_DB).Value = wks_dbi.Cells(1, 1).Value
For j = 1 To Anzahl_QEV_Nummern - 1
.Cells(i + 1, QEV_Spalte_DB).Value = wks_db.Cells(i + 1,  _
QEV_Spalte_DB).Value & ", " & wks_dbi.Cells(1 + j, 1).Value
Next j
End If
End With
With wks_dbi
.Activate
.Range(.Cells(1, 1), .Cells(Columns.Count, 112)).ClearContents
End With
If wks_mdb.FilterMode Then wks_mdb.ShowAllData
End If
Next i
Next k
'Workbooks("WERKSTOFFLISTE_2020-04.xlsx").Close SaveChanges:=False
End Sub

Anzeige
AW: Makro stürzt ab
26.05.2020 05:30:13
Archeangelos
-Repost da ich vergessen habe das Häkchen zu setzen!
Hallo Franz, erstmal vielen dank für die Bemühungen und die Tips für die Übersichtlichkeit,
Ich hab das heute nacht alles mal umgesetzt konnte das Problem aber leider immernoch nicht beheben.
Ich bekomme ich entweder den Laufzeitfehler 21474717848 (80010108) oder Excel stürzt direkt ab , ich weiß leider nicht welche werte i,j,k dabei haben da excel bei dem Laufzeitfehler komplett einfriert und sich nur über den taskmanager beenden lässt.
Zu deinen Fragen über den code:
1. Ich wollte eigentlich ohne das aktivieren von Tabellenblättern, d.h mit vollständigen Verweisen arbeiten allerdings hat das immer wieder zu Fehlermeldungen geführt die durch das vorherige aktivieren des jeweiligen Arbeitsblatt gelöst werden konnten.
2.Zeilen QEV_count war ein Fehler in meiner Programmierung: "Danke für den Hinweis =) , habe ich im neuen Code aber eh anders gelöst
3. Variablendeklaration habe ich nicht durchgehend gehabt, auch da mein Fehler!
4. Activeworkbook.AutoSaveOn : Das ausschalten des Autosaves in wks_db hat den Hintergrund dass ich dadurch ein einfrieren/ abstürzen durch eine zwischenspeicherung während des makrodurchlaufs verhindern wollte
5. Thisworkbook.Name : Mein Fehler, macht mit activeworkbook deutlich mehr sinn! THX
6. workbooks.open : ich habe in dem hier dargestellten code jediglich den tatsächlichen Dateipfad zwecks Datenschutzgründen durch "Dateipfad" ersetzt.
Falls es hilft vielleicht noch als Info: Das Makro muss eine Datei bearbeiten welche ziemlich umfangreich ist.
Daher läuft i bis ca. 3500
für k = 1;2 : j jeweils zw. 3-5
für k = 3 : j jeweils zw. 0-2
Das Makro stürzt in der Regel erst bei K = 2 und i > 2500 ab.
Ich geh dann jetzt mal schlafen und hoffe morgen ein Lösung zu finden.
Gute Nacht, und Grüße
Archeangelos
Den geänderten Quellcode hab ich hier: 
Sub QEV_Nummern_eintragen()
Dim wks_db As Worksheet
Dim wks_dbi As Worksheet
Dim wks_mdb As Worksheet
Dim k As Integer, i As Long, j As Long
Dim suchbegriff_leer As String
Dim suchbegriff_bind As String
Dim QEV_count As Long
Dim Materialspalte_DB As Long
Dim QEV_Spalte_DB As Long
Dim Datenbank_Count As Long
If Not ActiveWorkbook.Name = "Datenbank_V_017.xlsm" Then
Workbooks("Datenbank_V_017.xlsm").Activate
End If
Set wks_db = ThisWorkbook.Sheets("Datenbank_HSN")
Set wks_dbi = ThisWorkbook.Sheets("QEV_Import")
'Home PC
Workbooks.Open Filename:="Dateipfad"\WERKSTOFFLISTE_2020-04.xlsx"
Set wks_mdb = _
Workbooks("WERKSTOFFLISTE_2020-04.xlsx").Sheets("CAD-Werkstoffliste  2020-03")
For k = 1 To 3
With wks_db
If .FilterMode Then .ShowAllData
.Activate
If k = 1 Then
Materialspalte_DB = 1
QEV_Spalte_DB = 2
Datenbank_Count = WorksheetFunction.CountA(.Range("A:A")) - 2
ElseIf k = 2 Then
Materialspalte_DB = 6
QEV_Spalte_DB = 7
Datenbank_Count = WorksheetFunction.CountA(.Range("F:F")) - 2
ElseIf k = 3 Then
Materialspalte_DB = 11
QEV_Spalte_DB = 12
Datenbank_Count = WorksheetFunction.CountA(.Range("A:A")) - 2
End If
End With
For i = 1 To Datenbank_Count + 1
Eintragung = False
If Not wks_db.Cells(i + 1, Materialspalte_DB).Value = "" Then
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value & " *"
suchbegriff_bind = wks_db.Cells(i + 1, Materialspalte_DB).Value & "-*"
If InStr(1, suchbegriff_leer, "DBL") = 1 Then
suchbegriff_leer = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value
suchbegriff_bind = "*" & wks_db.Cells(i + 1, Materialspalte_DB).Value & "*"
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=10, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
Else
wks_mdb.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:= _
suchbegriff_leer, Operator:=xlOr, Criteria2:=suchbegriff_bind
End If
With wks_mdb
.Activate
If .Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells( _
xlCellTypeVisible).Count > 3 Then
Eintragung = True
Anzahl_QEV_Nummern = .Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row). _
_
SpecialCells(xlCellTypeVisible).Count - 3
.Range("B5:B" & wks_mdb.UsedRange.Rows.Count).SpecialCells( _
xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
_
SkipBlanks:=False, Transpose:=False
Else
wks_db.Activate
suchbegriff_leer = wks_db.Cells(i + 1, Materialspalte_DB).Value
.Activate
If .FilterMode Then .ShowAllData
.Range("$A$4:$S$5609").AutoFilter Field:=8, Criteria1:=suchbegriff_leer, _
_
Operator:=xlAnd
If .Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells( _
xlCellTypeVisible).Count > 3 Then
Eintragung = True
Anzahl_QEV_Nummern = .Range("B1:B" & Cells(Rows.Count, 2).End(xlUp). _
_
Row).SpecialCells(xlCellTypeVisible).Count - 3
.Range("B5:B" & wks_mdb.UsedRange.Rows.Count).SpecialCells( _
xlCellTypeVisible).Copy
wks_dbi.Activate
wks_dbi.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=  _
_
xlNone, SkipBlanks:=False, Transpose:=False
End If
End If
End With
With wks_db
If Eintragung = True Then
.Cells(i + 1, QEV_Spalte_DB).Clear
.Cells(i + 1, QEV_Spalte_DB).Value = wks_dbi.Cells(1, 1).Value
For j = 1 To Anzahl_QEV_Nummern - 1
.Cells(i + 1, QEV_Spalte_DB).Value = wks_db.Cells(i + 1,  _
QEV_Spalte_DB).Value & ", " & wks_dbi.Cells(1 + j, 1).Value
Next j
End If
End With
With wks_dbi
.Activate
.Range(.Cells(1, 1), .Cells(Columns.Count, 112)).ClearContents
End With
If wks_mdb.FilterMode Then wks_mdb.ShowAllData
End If
Next i
Next k
'Workbooks("WERKSTOFFLISTE_2020-04.xlsx").Close SaveChanges:=False
End Sub

Anzeige
AW: Makro stürzt ab
27.05.2020 17:42:48
fcs
Hallo Archeangelos,
die Fehler-Nummer sagt mir wenig, sie scheint aber irgendetwas mit dem Einfügen von kopierten Daten zu tun zu haben.
Ich hab das Makro noch mal etwas angepasst (einige Referenzen bei Rows.Count vervollständigt - spielt normalerweise keine Rolle solange alle involvierten Dateien in den Tabellenblättern die gleiche Zeilenzahl haben) und eine Fehlerbehandlung eingebaut.
An Hand er generierten Meldung kommst du evtl dem Fehler auf die Spur.
Die Variable iFehler zeigt an, in welchem Abschnitt des Makros der Fehler auftritt.
Der Wert für AutoSaveOn sollte ggf. in diesem Makro gesetzt werden. Denn wenn die Datei ""Datenbank_V_017.xlsm" beim Start des Makros nicht die aktive Datei sein sollte, dann wird in dem aufrufendem Makro der Wert für die falsche Datei gesetzt.
Text-Datei mit modifiziertem Makro
https://www.herber.de/bbs/user/137789.txt
LG
Franz
Anzeige
AW: Makro stürzt ab
30.05.2020 00:22:54
Archeangelos
Hallo Franz,
nochmals vielen Dank für deine Hilfe,
Ich hab jetzt mal versucht mit deinem error-Handler und rumprobieren den Fehler zu finden, leider ohne Erfolg,
Das Makro ist jetzt zwar zu ersten mal am Stück durchgelaufen, leider stürzt in 90% der Versuche (soweit ich es einschätzen kann immer gleiche Bedingungen) Excel komplett ab, und startet mit beiden geöffneten Worksbooks neu.
Es kam ein -2 mal vor das ich den Laufzeitfehler aus der letzten Antwort bekommen habe, leider konnte ich auch da mit deinem Error-Handler kein System dahinter finden. Ich hab ein Auszug der MSGBox mal hochgeladen.
Userbild
Ich weiß echt nicht mehr weiter.
Grüße
Archeangelos
Anzeige
AW: Makro stürzt ab
30.05.2020 08:14:17
fcs
Hallo Archeangelos,
mit Ferndiagnose wird es jetzt schwierig.
Ich hab jetzt noch eine fehlende Referenz gefunden aber in einem anderen Abschnitt des Makros. 
iFehler = 60
'                    .Activate
If .Range("B1:B" & Cells(.Rows.Count, 2).End(xlUp).Row).SpecialCells( _
_
xlCellTypeVisible).Count > 3 Then

anpassen in 
iFehler = 60
'                    .Activate
If .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).SpecialCells( _
xlCellTypeVisible).Count > 3 Then

Dies sollte aber keinen Einfluss auf den Fehler haben.
Wenn ja, dann am besten in ein ZIP-File packen.
Wenn die Dateien sehr groß sind, dann können wir den Austausch auch über meine MagentaCloud machen.
Meine E-Mail-Adresse findest du in meinem Profil. Das Profil erreichst du per Klick auf die kleine Grafik links neben meiner Antwort.
LG
Franz
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige