VBA-Problem: Excel-Datei wird als 'von anderer Person bearbeitet' gemeldet
#1
Hallo,
dieser Code funktioniert einwandfrei bei der Arbeit mit einem RDP-Server und der gleichen Excel-2016-Version. 

In Spalte D steht eine Produktionsnummer, die bereinigt wird. Anschließend wird die Datei nummer.xlsm geöffnet, 
der Wert aus Zelle C7 des Tabellenblatts "Eingabe" kopiert und in Spalte G eingefügt, dann die nächste Datei. 

Ich wollte den Code zu Hause ausprobieren, habe die gleiche Ordnerstruktur eingerichtet und die Pfade entsprechend angepasst. Alle Skripte funktionieren wie gewohnt, nur dieses nicht. Sobald die erste Datei gefunden wird, meldet Windows folgenden Fehler:

"135732.xlsm wird momentan von einer anderen Person bearbeitet. Versuchen Sie es später noch einmal."

Ich habe bereits mehrfach versucht, den Code anzupassen – auch mit Unterstützung von KI. 
Ich habe folgendes ausprobiert:Read-Only-Modus aktiviert, eine Kopie der Datei erstellt und daraus den Wert ausgelesen, eine 5-Sekunden-Verzögerung eingefügt, falls mein Rechner zu schnell ist.

Leider erhalte ich weiterhin dieselbe Fehlermeldung, dass die Datei von jemand anderem bearbeitet wird. 
Ich habe keinen weiteren Rechner zu Hause, um das Problem zu testen, und Windows scheint die Datei zu sperren. 
Auch mit Google bin ich nicht wirklich weitergekommen.

Hat jemand Tipps, woran das liegen könnte? Die Pfade sind definitiv korrekt.

Code:
Option Explicit

Sub ArtikelnummerAuslesenUndEintragen()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim prodNum As String
    Dim maschine As String
    Dim pfad As String
    Dim jahrOrdner As String
    Dim monatOrdner As String
    Dim dateiPfad As String
    Dim wbQuelle As Workbook
    Dim artikelnummer As String
    Dim pruefwert As Variant
    Dim i As Long
    Dim jahr As Long
    Dim monat As Long
    Dim reineNummer As String
   
    ' Bildschirmaktualisierungen deaktivieren
    Application.ScreenUpdating = False
   
    ' Aktuelles Tabellenblatt
    Set ws = ThisWorkbook.ActiveSheet
    maschine = ws.Name

    ' Letzte Zeile in Spalte D
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    ' Schleife durch alle Produktionsnummern in Spalte D
    For i = 2 To lastRow
        If ws.Cells(i, "D").Value <> "" And (ws.Cells(i, "G").Value = "" Or ws.Cells(i, "J").Value = "") Then
            prodNum = ws.Cells(i, "D").Value
           
            ' Extrahiere die reine Nummer aus der Produktionsnummer und entferne führende Nullen
            If InStr(prodNum, "-") > 0 Then
                reineNummer = CStr(CLng(Mid(prodNum, InStr(prodNum, "-") + 1))) ' Führende Null entfernen
            Else
                reineNummer = CStr(CLng(prodNum)) ' Falls kein Bindestrich vorhanden ist
            End If

            artikelnummer = "" ' Artikelnummer zurücksetzen
            pruefwert = "" ' Prüfwert zurücksetzen

            ' Suche die Datei in den Jahres- und Monatsordnern
            For jahr = Year(Date) - 1 To Year(Date) ' Prüfe die letzten 2 Jahre
                jahrOrdner = CStr(jahr)

                For monat = 1 To 12
                    monatOrdner = Format(monat, "00")
                    'pfad = "\\pm-rdp-003\PRODUKTION\" & maschine & "\Produktion\" & jahrOrdner & "\" & monatOrdner & "\\"
                    pfad = "C:\LOESCHEN\" & maschine & "\Produktion\" & jahrOrdner & "\" & monatOrdner & "\\"

                    ' Überprüfen, ob die Datei existiert
                    dateiPfad = pfad & reineNummer & ".xlsm"
                    If Dir(dateiPfad) <> "" Then
                        ' Datei öffnen
                        On Error Resume Next
                        Set wbQuelle = Workbooks.Open(dateiPfad, ReadOnly:=True)
                        On Error GoTo 0

                        If Not wbQuelle Is Nothing Then
                            ' Artikelnummer auslesen
                            On Error Resume Next
                            artikelnummer = wbQuelle.Worksheets("Eingabe").Range("C7").Value
                            pruefwert = wbQuelle.Worksheets("Prüfbericht").Range("AW12").Value
                            On Error GoTo 0

                            ' Datei schließen
                            wbQuelle.Close SaveChanges:=False
                            Set wbQuelle = Nothing

                            ' Artikelnummer eintragen, wenn noch nicht vorhanden
                            If artikelnummer <> "" And ws.Cells(i, "G").Value = "" Then
                                ws.Cells(i, "G").Value = artikelnummer
                            End If

                            ' Prüfwert eintragen, wenn noch nicht vorhanden
                            If Not IsEmpty(pruefwert) And ws.Cells(i, "J").Value = "" Then
                                ws.Cells(i, "J").Value = pruefwert
                                'MsgBox pruefwert
                            End If

                            ' Beende die Schleife, wenn Datei gefunden wurde
                            Exit For
                        End If
                    End If
                Next monat
            Next jahr
        End If
    Next i

    ' Bildschirmaktualisierungen wieder aktivieren
    Application.ScreenUpdating = True

    ' Fertigmeldung
    'MsgBox "Artikelnummern und Prüfwerte wurden eingetragen!", vbInformation
End Sub
Antworten Top
#2
Hallo,

dein Makro scheint erstmal in Ordnung zu sein, wenn du den doppelten Backslash in
Code:
... & monatOrdner & "\\"
korrigierst, der gehört da nicht hin.

Allerdings sind das .xlsm Dateien, welche potentiell auch Makros enthalten können. Vielleicht ist dabei etwas im Argen?

Gruß
Knobbi38
Antworten Top
#3
Wink 
Mit den doppelten Backslashes habe ich mich vorher vertippt, sorry
Auf dem RDP-Server funktioniert es mit zwei, lokal auf dem Rechner jedoch nur mit einem Backslash. 

Ich habe den Fehler gerade zufällig entdeckt, mit ReadOnly=False läuft es wie bei der Arbeit
Code:
                    ' Überprüfen, ob die Datei existiert
                    dateiPfad = pfad & reineNummer & ".xlsm"
                    If Dir(dateiPfad) <> "" Then
                        ' Datei öffnen
                        On Error Resume Next
                        Set wbQuelle = Workbooks.Open(dateiPfad, ReadOnly:=False)
                        On Error GoTo 0
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste