Grande Katastophe

Nordic · 2024-07-16T13:13:03+00:00

Hallo, nach dem ich heute früh einen VBA-Code verbaut habe, der abhängig von einem Suchergebnis in der Spalte A eine Zelle grün markiert und bei Worksheet_SelectionChange wieder entfernt (zuvor hatte ich gesamte Trefferzeile selektiert, was bei Unachtsamkeit auch mal zum Überschreiben von Zellinhalten führte) hat's geknallt. Die Datei benötigte extrem viel Zeit zum Öffnen und jeder Aktion führte zum "einfrieren" (keine Rückmeldung). Auffällig war\ist auch, dass die Datei von ursprünglich 740KB auf 9MB angewachsen ist. Mit abgesichertem Modus und deaktivierten Makros konnte ich die Datei leidlich wieder öffnen. Da auch das auskommentieren des zuletzt hinzugefügten Code keinen Erfolg brachte habe ich alle Daten gelöscht (diese können einfach wieder hergestellt werden), sowie den kompletten VBA Code aller Tabellen, Formulare und Module gesichert und ebenfalls aus dem Projekt entfernt. Leider blieb auch dies ohne wirklich sichtbaren Erfolg. Die Datei öffnet wieder etwas schnell ist aber trotz dem Entfernen der Daten und des VBA-Code immer noch knapp 9MB groß. Die Arbeitsmappenüberprüfung auf Probleme brachte mich ebenfalls nicht weiter. Ich hoffe sehr, dass jemand eine Idee hat. Grüße, Uwe Bevor nun jemand ketzerisch nach einem Backup fragt ;) Ich schwör, ich wollte das (vor einiger Zeit) machen :)

Guten Morgen :)
Ich habe nun mit Dokumentenprüfung, mit Inquire "rumgetüddelt" und alle bedingten Formatierungen rausgenommen.
Nach dem ich die Scroll Restrictions entfernt hatte, wurde offenbar, was ich ahnte...
Beim Testen des Stammdatenimport hatte ich wohl das eine oder andere mal Daten im oberen Bereich übersehen, die neuen wurden angehängt - über die Scroll Restriction hinaus. Also habe ich auch das alles gelöscht. Außer ein paar KB brachte das nicht viel. Es blieb bei nun ~8,5MB (ursprünglich ~ 750KB)
Zuletzt habe ich alle Tabellenblätter jedes für sich in eine neue Mappe kopiert...
Ergebnis: Der Wurm ist in den ersten beiden (Stammdaten 2,6MB, 119-16-23 5,5MB), alle anderen haben eine erwartbare Größe ( alle zusammen ~440KB)
Die Einzelteile hab ich mal in der Dropbox abgelegt:
https://www.dropbox.com/scl/fo/710j56r2b8prw7kx1x3hz/AFr1iN_r68qzOWSbQqdjixU?rlkey=bl62ipte6rfmr0ybzosmi4ly0&dl=0

Kann es irgendwo noch einen versteckten Bereich geben, in dem Daten abgelegt wurde?
Um die Stammdaten vom System in die Exceldatei zu bekommen kann ich nur über den Weg gehen, mir für alle markierten Teilnehmer einen Stammdatenbericht genieren zu lassen und diesen als PDF zu speichern. Mit Hilfe von pdftotext und einem Phython-Script zieh ich dort die benötigten Daten raus und lass mir eine Exceldatei erstellen, die fix und fertig nur noch importiert werden muss

Sub DataImport()

    Dim wsDest As Worksheet

    Dim wsSrc As Worksheet

    Dim wbSrc As Workbook

    Dim lastRowDest As Long

    Dim lastRowSrc As Long

    Dim lastColSrc As Long

    Dim nextRowDest As Long

    Dim srcRange As Range

    Dim cell As Range

    Dim i As Long, j As Long

    Dim duplicate As Boolean

    Dim importFilePath As String

    Dim backupFilePath As String

    Dim newFileName As String

    Dim timestamp As String

    Dim newRows As Collection

    Dim newRow As Long

    Dim fso As Object

    Dim logFilePath As String

    Dim logMessage As String

    

    Set wsDest = ThisWorkbook.Sheets("Stammdaten")

    

    importFilePath = ThisWorkbook.Path & "\Import\Stammdaten.xlsx"

    logFilePath = ThisWorkbook.Path & "\Bin64\Logs\error_log.txt"

    

    Set fso = CreateObject("Scripting.FileSystemObject")

    

    If Not fso.FileExists(importFilePath) Then

        logMessage = GetCurrentTimestamp() & " - ImportStammdaten - Import file not found: " & importFilePath

        WriteToLog logFilePath, logMessage

        MsgBox "Die Importdatei wurde nicht gefunden.", vbCritical

        Exit Sub

    End If

    

    Set wbSrc = Workbooks.Open(importFilePath)

    Set wsSrc = wbSrc.Sheets(1)

    

    lastRowSrc = wsSrc.Cells(wsSrc.Rows.Count, 1).End(xlUp).Row

    lastColSrc = wsSrc.Cells(2, wsSrc.Columns.Count).End(xlToLeft).Column

    

    nextRowDest = wsDest.Cells(wsDest.Rows.Count, 3).End(xlUp).Row + 1

    If nextRowDest  7 Then nextRowDest = 7

    

    Set srcRange = wsSrc.Range(wsSrc.Cells(2, 1), wsSrc.Cells(lastRowSrc, lastColSrc))

    

    Set newRows = New Collection

    

    For Each cell In srcRange.Rows

        duplicate = False

        

        For i = 7 To wsDest.Cells(wsDest.Rows.Count, 3).End(xlUp).Row

            duplicate = True

            For j = 1 To lastColSrc

                If wsDest.Cells(i, j + 2).value > cell.Cells(1, j).value Then

                    duplicate = False

                    Exit For

                End If

            Next j

            If duplicate Then Exit For

        Next i

        

        If Not duplicate Then

            wsDest.Cells(nextRowDest, 3).Resize(1, lastColSrc).value = cell.Resize(1, lastColSrc).value

            newRows.Add nextRowDest

            nextRowDest = nextRowDest + 1

        End If

    Next cell

    

    wbSrc.Close SaveChanges:=False

    

    CopyNewRowsToSpecificSheets wsDest, newRows

    

    timestamp = Format(Now, "yyyy.mm.dd_hh.mm.ss")

    

    newFileName = timestamp & ".xlsx"

    backupFilePath = ThisWorkbook.Path & "\Import\Backup\" & newFileName

    Name importFilePath As backupFilePath

    

    logMessage = GetCurrentTimestamp() & " - ImportStammdaten - Import and processing completed successfully."

    WriteToLog logFilePath, logMessage

    

    MsgBox "Import- und Kopiervorgang abgeschlossen!", vbInformation

End Sub



Sub CopyNewRowsToSpecificSheets(wsDest As Worksheet, newRows As Collection)

    Dim ws119_16_23 As Worksheet

    Dim ws119_6_24 As Worksheet

    Dim rowNum As Variant

    Dim nextRow119_16_23 As Long

    Dim nextRow119_6_24 As Long

    Dim dateValue As Date

    

    Set ws119_16_23 = ThisWorkbook.Sheets("119-16-23")

    Set ws119_6_24 = ThisWorkbook.Sheets("119-6-24")

    

    nextRow119_16_23 = ws119_16_23.Cells(ws119_16_23.Rows.Count, 2).End(xlUp).Row + 1

    If nextRow119_16_23  7 Then nextRow119_16_23 = 7

    

    nextRow119_6_24 = ws119_6_24.Cells(ws119_6_24.Rows.Count, 2).End(xlUp).Row + 1

    If nextRow119_6_24  7 Then nextRow119_6_24 = 7

    

    For Each rowNum In newRows

        dateValue = wsDest.Cells(rowNum, 14).value

        

        If wsDest.Cells(rowNum, 13).value = "119-16-23" Then

            ws119_16_23.Cells(nextRow119_16_23, 2).value = wsDest.Cells(rowNum, 3).value

            ws119_16_23.Cells(nextRow119_16_23, 6).value = dateValue

            ws119_16_23.Cells(nextRow119_16_23, 7).value = "x"

            ws119_16_23.Cells(nextRow119_16_23, 14).value = "x"

            nextRow119_16_23 = nextRow119_16_23 + 1

        ElseIf wsDest.Cells(rowNum, 13).value = "119-6-24" Then

            ws119_6_24.Cells(nextRow119_6_24, 2).value = wsDest.Cells(rowNum, 3).value

            ws119_6_24.Cells(nextRow119_6_24, 6).value = dateValue

            ws119_6_24.Cells(nextRow119_6_24, 7).value = "x"

            ws119_6_24.Cells(nextRow119_6_24, 14).value = "x"

            nextRow119_6_24 = nextRow119_6_24 + 1

        End If

    Next rowNum

End Sub

Was mir beim Testen aufgefallen ist:
Der jeweils erste Import und das Verteilen von rund 100 Datensätze in leere Tabellenblätter dauert nachvollziehbar ein paar Sekunden.
Lösche ich alle Daten und mach das ganze von vorn, ist es gefühlt nur ein "Wimpernschlag" bis sie im Blatt Stammdaten verfügbar sind.
Das Verteilen geht auch etwas schneller, aber nicht signifikant.
Speichere ich die Datei leer, schließe und öffne sie wieder, dauert der erste Import wieder ein paar Sekunden.
Es fühlt sich so an, als ob die Importdaten nach dem ersten Importieren zur Laufzeit irgendwo im Hintergrund liegen.
Der Gedanke: Vielleicht wurden diese beim "Crash" irgendwie "unsichtbar" mitgespeichert.
Kann das sein?

Das Blöde ist, ich wechsle das Unternehmen zum 31.07. und hätte mein "Privatprojekt" (ich hatte nie einen offiziellen Auftrag dazu, aber die wohlwollendende Duldung auch mal in der Arbeitszeit mich dem ein paar Stunden zu widmen) schon gerne eine funktionstüchtige und in einem gewissen Rahmen komplette Version hinterlassen.

Viele Grüße und einen guten Start in den Tag, Uwe

Moin Daniel,
das bringt mich auf eine Idee.
Ich hatte schon länger ein Set Scroll Restrictions via VBA hinterlegt.
Mit der Vermutung, dass in den "verbotenen" Bereichen was rumliegt, was da nicht sein sollte, wollte ich das irgendwie rückgängig machen.
In den jeweiligen Tabelleneigenschaften ist dort aber kein Eintrag zu finden.

Der Code in GerneralServices dazu:

Public Sub SetScrollRestrictions()

    Dim maxScrollRow As Long

    Dim ws As Worksheet

    Set ws = ActiveSheet



    ws.Unprotect password:="2024"



    Select Case ws.name

        Case "Stammdaten"

            maxScrollRow = 166

        Case "119-16-23", "119-6-24"

            maxScrollRow = 97

        Case "Unterrichtsplan"

            maxScrollRow = 48

        Case "Nachbetreuung"

            maxScrollRow = 36

        Case Else

            maxScrollRow = ws.Rows.Count

    End Select



    ActiveWindow.ScrollRow = 1

    If maxScrollRow  ws.Rows.Count Then

        ws.Rows(maxScrollRow + 1 & ":" & ws.Rows.Count).Interior.Color = RGB(255, 255, 255)

        ws.Rows(maxScrollRow + 1 & ":" & ws.Rows.Count).EntireRow.Hidden = True

    End If



    ws.Protect password:="2024"

    Application.ScreenUpdating = True

End Sub

Was das ganze zum "Crash" führte:

Ausgehend von der Suche auf einem Tabellenblatt (z.B. Stammdaten):

Private Sub txtSearch_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    If KeyCode = 13 Then

        GeneralServices.HandleSearch 1, "C", txtSearch.value, 3, 14

        txtSearch.Text = ""

    End If

End Sub

Modul GeneralServices:

Public Sub HandleSearch(sheetIndex As Integer, searchColumn As String, searchValue As String, Optional selectRangeStart As Integer = 2, Optional selectRangeEnd As Integer = 13)

   Dim ws As Worksheet

   Dim cell As Range

   Dim found As Boolean

   Application.ScreenUpdating = False



   Set ws = Worksheets(sheetIndex)



   If Trim(searchValue) = "" Then

       Application.ScreenUpdating = True

       Exit Sub

   End If



   ThisWorkbook.Unprotect password:="2024"

   ws.Unprotect password:="2024"



   RemovePreviousMarkings ws



   found = False

   For Each cell In ws.Columns(searchColumn).Cells

       If InStr(1, cell.value, searchValue, vbTextCompare) > 0 And cell.Row >= 7 Then

           ws.Cells(cell.Row, 1).Interior.Color = RGB(0, 255, 0) 

           found = True

           Exit For

       End If

   Next cell



   ws.Protect password:="2024", UserInterfaceOnly:=True

   ThisWorkbook.Protect password:="2024"



   Application.ScreenUpdating = True



   If Not found Then

       MsgBox "Suchbegriff nicht gefunden.", vbExclamation

   End If

End Sub



Public Sub SelectionChangeHandler(ws As Worksheet)

   On Error Resume Next

   ws.Unprotect password:="2024"

   RemovePreviousMarkings ws

   ws.Protect password:="2024", UserInterfaceOnly:=True

   On Error GoTo 0

End Sub



Public Sub RemovePreviousMarkings(ws As Worksheet)

   Dim cell As Range

   For Each cell In ws.Columns("A").Cells

       If cell.Interior.Color = RGB(0, 255, 0) Then

           cell.Interior.ColorIndex = xlNone

       End If

   Next cell

End Sub

Und am Ende des Tabellenblatt:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

   GeneralServices.SelectionChangeHandler Me

End Sub

Ich weiß, ist nicht optimal, aber vielleicht sieht Du wo der Crash passiert ist, damit ich mir den nicht noch mal bau.

Grüße, Uwe

Forumthread: Grande Katastophe

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Grande Katastophe

Forumthread: Grande Katastophe

22 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread