Excel (VBA GetObject) Netzwerkpfad

Althir81 · 26. August 2020

Hallo Community,

vermutlich habe ich einfach einen Denkfehler... ich soll mich um ein Excelsheet mit folgendem VBA Code kümmern

Code:

Function LeereStellen() As Boolean

    With Tabelle1
    
        'Artikelnummer
        On Error GoTo Namen
        If .Cells(2, 2) = "" Then
            .Cells(2, 1).Font.Color = RGB(255, 0, 0)
        Else
            .Cells(2, 1).Font.Color = RGB(0, 0, 0)
        End If
        
        'Charge:
        If .Cells(3, 2) = "" Then
            .Cells(3, 1).Font.Color = RGB(255, 0, 0)
        Else
            .Cells(3, 1).Font.Color = RGB(0, 0, 0)
        End If
        
        'Werkstoff
        If .Cells(4, 2) = "" Then
            .Cells(4, 1).Font.Color = RGB(255, 0, 0)
        Else
            .Cells(4, 1).Font.Color = RGB(0, 0, 0)
        End If
        
        'Produktionsanlage und Produktionszeitraum nur für Extrusion
        If .Cells(6, 6) <> 4 Then
            
            'Produktionsanlage
            If .Cells(11, 2) = "" Then
                .Cells(11, 1).Font.Color = RGB(255, 0, 0)
            Else
                .Cells(11, 1).Font.Color = RGB(0, 0, 0)
            End If
            
            'Produziert von
            If .Cells(11, 5) = "" Then
                .Cells(11, 4).Font.Color = RGB(255, 0, 0)
            Else
                .Cells(11, 4).Font.Color = RGB(0, 0, 0)
            End If
            
            'Produziert bis
            If .Cells(11, 9) = "" Then
                .Cells(11, 8).Font.Color = RGB(255, 0, 0)
            Else
                .Cells(11, 8).Font.Color = RGB(0, 0, 0)
            End If
            
        End If
        
        'Meldung ausgeben, dass nicht alle Daten gepflegt sind
        If .Cells(2, 1).Font.Color Or .Cells(3, 1).Font.Color Or _
        .Cells(4, 1).Font.Color Or .Cells(11, 2).Font.Color Or .Cells(11, 4).Font.Color _
        Or .Cells(11, 6).Font.Color = RGB(255, 0, 0) Then
            
            MsgBox "Bitte alle erforderlichen Daten eingeben", vbOKOnly
            LeereStellen = False
            
        Else
        
            LeereStellen = True
        
        End If
        
    End With
    
    Exit Function
    
Namen:
    MsgBox "Bitte die Eingaben prüfen", vbOKOnly
    
End Function
        
Function Ausschussgrund() As Boolean
        
    With Tabelle1
    
        'Meldung ausgeben, dass kein Ausschussgrund angegeben wurde
        If .Cells(22, 3) = False And .Cells(23, 3) = False And .Cells(24, 3) = False And .Cells(25, 3) = False And .Cells(26, 3) = False _
            And .Cells(27, 3) = False And .Cells(28, 3) = False And .Cells(29, 3) = False And .Cells(30, 3) = False And .Cells(31, 3) = False _
            And .Cells(32, 3) = False And .Cells(33, 3) = False And .Cells(34, 3) = False And .Cells(35, 3) = False And .Cells(36, 3) = False _
            And .Cells(21, 4) = False And .Cells(22, 4) = False And .Cells(24, 4) = False And .Cells(25, 4) = False And .Cells(21, 5) = False _
            And .Cells(22, 5) = False And .Cells(23, 5) = False And .Cells(24, 5) = False And .Cells(21, 6) = False And .Cells(22, 6) = False Then
                
            MsgBox "Bitte einen Ausschussgrund auswählen", vbOKOnly
            Ausschussgrund = False
                
        Else
        
            Ausschussgrund = True

        End If
        
    End With

End Function

Private Sub cmdSpeichern_Click()

    Dim strArtikel, strBA, strWerkstoff, strErsteller, strDatum, strVon, strBis, _
        intKategorie, intErkannt, intFertiger, intAnlage, intGut, intAWare, intBWare, intSchrott, intMuster, _
        blnAAusbruch, blnAEinfallstelle, blnAKurzlaenge, blnAMittenversatz, blnALunker, blnARisse, blnAForm, _
        blnAKaltstelle, blnABambus, blnAAnbackeffekt, blnAMaßhaltigkeit, blnAFließlinien, blnASchuppen, _
        blnAAnfahrausschuss, blnBVisko, blnBAnbackeffekt, blnBAusspuelungen, blnBPunkte, blnSFremdkoerper, _
        blnSMetall, blnSUebertempert, blnSVerbrannt, blnMMaß, blnMErstmuster, strEinheit, strBemerkung, _
        blnLeereStellen, blnAusschussgrund, blnAReststueck, intGutProzent, intAWareProzent, intBWareProzent, _
        intSchrottProzent, intMusterProzent, intKW, shQuelle, blnBeendet, strWeiss, strGelb, intAnfahrM, intAnfahrP, _
        intZeile As Integer, blnABindenaht, blnAPoren, blnAFuellung
    Dim wkbZiel As Workbook, wkbDaten As Workbook, wkbQuelle As Workbook

    Application.ScreenUpdating = False
    
    Set wkbQuelle = ThisWorkbook
    
    blnLeereStellen = LeereStellen
    blnAusschussgrund = Ausschussgrund
    
    If blnLeereStellen Or blnAusschussgrund = True Then
        
        'Daten übergeben
        With Tabelle1
        
            strArtikel = .Cells(2, 2)
            strBA = .Cells(3, 2)
            strWerkstoff = .Cells(4, 2)
            strErsteller = .Cells(2, 4)
            strDatum = .Cells(3, 4)
            strVon = .Cells(11, 4)
            strBis = .Cells(11, 6)
            intKategorie = .Cells(6, 6)
            intErkannt = .Cells(10, 6)
            intFertiger = .Cells(10, 5)
            intAnlage = .Cells(11, 2)
            strEinheit = .Cells(16, 1)
            intGut = .Cells(16, 2)
            intGutProzent = .Cells(18, 2)
            intAWare = .Cells(16, 3)
            intAWareProzent = .Cells(18, 3)
            intBWare = .Cells(16, 4)
            intBWareProzent = .Cells(18, 4)
            intSchrott = .Cells(16, 5)
            intSchrottProzent = .Cells(18, 5)
            intMuster = .Cells(16, 6)
            intMusterProzent = .Cells(18, 6)
            strBemerkung = .Cells(43, 1)
            blnAAusbruch = .Cells(25, 3)
            blnAEinfallstelle = .Cells(27, 3)
            blnAKurzlaenge = .Cells(38, 3)
            blnAMittenversatz = .Cells(40, 3)
            blnALunker = .Cells(30, 3)
            blnAPoren = .Cells(31, 3)
            blnASchuppen = .Cells(32, 3)
            blnARisse = .Cells(36, 3)
            blnAForm = .Cells(37, 3)
            blnAFuellung = .Cells(28, 3)
            blnAKaltstelle = .Cells(29, 3)
            blnABambus = .Cells(26, 3)
            blnAAnbackeffekt = .Cells(22, 5)
            blnAMaßhaltigkeit = .Cells(39, 9)
            blnAFließlinien = .Cells(34, 3)
            blnAReststueck = .Cells(41, 3)
            blnAAnfahrausschuss = .Cells(24, 3)
            blnBVisko = .Cells(36, 5)
            blnBAnbackeffekt = .Cells(22, 5)
            blnBAusspuelungen = .Cells(33, 5)
            blnBPunkte = .Cells(34, 5)
            blnSFremdkoerper = .Cells(37, 7)
            blnSMetall = .Cells(38, 7)
            blnSUebertempert = .Cells(34, 7)
            blnSVerbrannt = .Cells(36, 7)
            blnSBW = .Cells(33, 7)
            blnMMaß = .Cells(39, 9)
            blnMErstmuster = .Cells(37, 9)
            blnABindenaht = .Cells(33, 3)
            blnBeendet = .Cells(12, 6)
            strWeiss = .Cells(37, 1)
            strGelb = .Cells(39, 1)
            
            If .Cells(24, 3) = True Then
                intAnfahrM = .Cells(25, 2)
                intAnfahrP = .Cells(26, 2)
            End If
            
        End With
        
        If Tabelle1.Cells(6, 6) <> 4 Then
            On Error GoTo Datei
            Set wkbZiel = GetObject("\\FILE-01\Extrusion\Laufende Produktionen\" & strArtikel & "_BA" & strBA & ".xlsm")
        End If
        
        intZeile = 1
        
        'Datenconainer öffnen und Daten übergeben
        Set wkbDaten = Workbooks.Open("\\Q:\Qualitätssicherung\Datencontainer\Ausschuss_Extrusion.xlsx")
    
        'Leere Zeile finden
        Do While Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("A" & intZeile) <> ""
            intZeile = intZeile + 1
        Loop
        
        'Daten in die Datei schreiben
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("A" & intZeile) = intZeile - 1
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("B" & intZeile) = strArtikel
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("C" & intZeile) = strBA
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("D" & intZeile) = strWerkstoff
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("E" & intZeile) = intKategorie
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("F" & intZeile) = strErsteller
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("G" & intZeile) = strDatum
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("H" & intZeile) = intErkannt
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("I" & intZeile) = intFertiger
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("J" & intZeile) = intAnlage
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("K" & intZeile) = strVon
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("L" & intZeile) = strBis
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("M" & intZeile) = strEinheit
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("N" & intZeile) = intGut
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("O" & intZeile) = intGutProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("P" & intZeile) = intAWare
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("Q" & intZeile) = intAWareProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("R" & intZeile) = intBWare
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("S" & intZeile) = intBWareProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("T" & intZeile) = intSchrott
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("U" & intZeile) = intSchrottProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("V" & intZeile) = intMuster
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("W" & intZeile) = intMusterProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("X" & intZeile) = strBemerkung
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("Y" & intZeile) = blnAAusbruch
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("Z" & intZeile) = blnAEinfallstelle
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AA" & intZeile) = blnAKurzlaenge
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AB" & intZeile) = blnAMittenversatz
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AC" & intZeile) = blnALunker
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AD" & intZeile) = blnAPoren
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AE" & intZeile) = blnARisse
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AF" & intZeile) = blnAForm
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AG" & intZeile) = blnAFuellung
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AH" & intZeile) = blnAKaltstelle
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AI" & intZeile) = blnABambus
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AJ" & intZeile) = blnAAnbackeffekt
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AK" & intZeile) = blnAMaßhaltigkeit
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AL" & intZeile) = blnAFließlinien
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AM" & intZeile) = blnAReststueck
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AN" & intZeile) = blnASchuppen
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AO" & intZeile) = blnAAnfahrausschuss
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AP" & intZeile) = blnABindenaht
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AQ" & intZeile) = blnBVisko
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AR" & intZeile) = blnBAnbackeffekt
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AS" & intZeile) = blnBAusspuelungen
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AT" & intZeile) = blnBPunkte
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AU" & intZeile) = blnSFremdkoerper
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AV" & intZeile) = blnSMetall
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AW" & intZeile) = blnSUebertempert
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AX" & intZeile) = blnSVerbrannt
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AY" & intZeile) = blnSBW
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AZ" & intZeile) = blnMMaß
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BA" & intZeile) = blnMErstmuster
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BB" & intZeile) = blnBeendet
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BC" & intZeile) = strWeiss
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BD" & intZeile) = strGelb
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BE" & intZeile) = intAnfahrM
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BF" & intZeile) = intAnfahrP

        'Datencontainer schließen und speichern
        wkbDaten.Close (True)
        
        'Tabellenblatt in Prüfprotokoll von entsprechender BA kopieren (nur bei Extrusion)
        Set shQuelle = ThisWorkbook.ActiveSheet
        
        Tabelle1.Cells(4, 7) = intZeile - 1
        
        If Tabelle1.Cells(6, 6) <> 4 Then
            
            Windows(wkbZiel.Name).Visible = True
            'Hinter letztes Tabellenblatt speichern
            shQuelle.Copy After:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
            'Tebellenblattname ändern und mit KW versehen
            intKW = Format(Date, "ww", 2, 3)
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).Name = "Auschussquittung_KW" & intKW
            'Speichernbutton löschen
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).Shapes.Range(Array("cmdSpeichern")).Delete
            'Benutzernamen und Datumkopieren und als Werte wieder einfügen
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).Range("E2:F3").Copy
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).Range("E2:F3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

            'Protokolldatei speichern
            wkbZiel.Save
            
            'Ausschussquittung ausdrucken
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).PrintOut Copies:=2
            
        Else
        
            'Ausschussquittung drucken SPAN
            wkbQuelle.PrintOut

        End If
        
        
        'Bildschirmaktivität einschalten
        Application.ScreenUpdating = True
        
        'Formulat ohne speichern schließen
        wkbQuelle.Close SaveChanges:=False
    
    End If
    
    Exit Sub
        
Datei:
    MsgBox "Zieldatei nicht gefunden. Bitte Name und Speicherort überprüfen", vbOKOnly, "Zieldatei nicht gefunden"

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

Beim drücken des Buttons zum Speichern, meldet er Zieldatei nicht gefunden.
Die Pfade sind erreichbar...

Falls Ihr noch weitere Infos benötigt, gern kurz melden.

Danke & Gruß
Oliver

Wurzelsepp29 · 26. August 2020

Hallo Oliver,

ich vermute es liegt am Backslash \, der Pfad muss in VBA aber mit normalen Slash / angegeben werden.

Kleiner Tipp, mit den richtigen Referenzen auf die jeweiligen Dateien könnte man sich den Weg über die Variablen sparen und direkt aus der Quelldatei in die Zieldatei schreiben.
Zudem ist diese riesen Menge an Variablen alle als Variant, sprich dem Datentyp mit dem größten Speicherbedarf, deklariert. Nicht sehr effizient, auch wenn es bei so einem kleinen Programm eher nicht auffällt.

VG

tollertyp · 26. August 2020

Warum stehten vor Q:\ hier zwei Backslashes?

Workbooks.Open("\\Q:\Qualitätssicherung\...

Du sagst die Pfade sind erreichbar. Ich wette 100 Euro drauf, dass du "\\Q:\Qualitätssicherung" nicht im Explorer erreichst, wenn du das so eingibst, oder auch nicht auf der Kommandozeile, wenn du es so aufrufst:

Code:

cd "\\Q:\Qualitätssicherung"

Und dein On Error verschleiert halt die Stelle, wo der Fehler passiert ist.

@Wurzelsepp29: Stimmt.
Kannst den Deppen von Microsoft ja auch mal sagen, dass sie ihre Dokumentation anpassen sollen:
https://docs.microsoft.com/de-de/of...erence/user-interface-help/getobject-function
(Vorsicht: das war Sarkasmus)

Althir81 · 26. August 2020

Hallo Wurzelsepp,

Danke für den Hinweis, werde es ausprobieren.
Ja das ganze wird, sobald final, in die Warenwirtschaft programmiert.

Ergänzung (26. August 2020)

tollertyp schrieb:
Warum stehten vor Q:\ hier zwei Backslashes?

@Wurzelsepp29: Stimmt.
Kannst den Deppen von Microsoft ja auch mal sagen, dass sie ihre Dokumentation anpassen sollen:
https://docs.microsoft.com/de-de/of...erence/user-interface-help/getobject-function

Deshalb kam ich auch nicht auf die "Backslashes"... Die Datei lief so schon einmal, ich sollte nur rausfinden weshalb Sie nicht mehr läuft...

Die \\ vor dem Q:\ fand ich auch verwirrend...

Also wirklich jeden Backslash durch Slash tauschen? Macht imho für mich jetzt eigentlich keinen Sinn...

Wurzelsepp29 · 26. August 2020

Die Dokumentation ist gruselig. Bspw. gibt es die Möglichkeit, den Blattschutz zu aktivieren (Worksheet.protect), führt man diese Methode zweimal nacheinander aus, zeigt Excel zwar "Blattschutz aufheben" in der Menüleiste an, man kann aber dennoch alle gesperrten Zellen bearbeiten.

Ergänzung (26. August 2020)

Althir81 schrieb:
Die \\ vor dem Q:\ fand ich auch verwirrend...

Sollte ohne auch funktionieren, es muss nur sichergestellt sein, dass der Pfad auch immer unter Q: liegt (kann ja theoretisch je nach User abweichen)

Althir81 · 26. August 2020

Wurzelsepp29 schrieb:
Die Dokumentation ist gruselig. Bspw. gibt es die Möglichkeit, den Blattschutz zu aktivieren (Worksheet.protect), führt man diese Methode zweimal nacheinander aus, zeigt Excel zwar "Blattschutz aufheben" in der Menüleiste an, man kann aber dennoch alle gesperrten Zellen bearbeiten.

Ergänzung (26. August 2020)

Sollte ohne auch funktionieren, es muss nur sichergestellt sein, dass der Pfad auch immer unter Q: liegt (kann ja theoretisch je nach User abweichen)

Q:\ Wird bei den betroffenen Nutzern automatisch bei Login verbunden und ist somit immer Q:\

also ohne die \\ vor dem Q:\ will er auch nicht... Backslashes mit Slashes getauscht, wollen auch nicht helfen...

Code:

Function LeereStellen() As Boolean

    With Tabelle1
  
        'Artikelnummer
        On Error GoTo Namen
        If .Cells(2, 2) = "" Then
            .Cells(2, 1).Font.Color = RGB(255, 0, 0)
        Else
            .Cells(2, 1).Font.Color = RGB(0, 0, 0)
        End If
      
        'Charge:
        If .Cells(3, 2) = "" Then
            .Cells(3, 1).Font.Color = RGB(255, 0, 0)
        Else
            .Cells(3, 1).Font.Color = RGB(0, 0, 0)
        End If
      
        'Werkstoff
        If .Cells(4, 2) = "" Then
            .Cells(4, 1).Font.Color = RGB(255, 0, 0)
        Else
            .Cells(4, 1).Font.Color = RGB(0, 0, 0)
        End If
      
        'Produktionsanlage und Produktionszeitraum nur für Extrusion
        If .Cells(6, 6) <> 4 Then
          
            'Produktionsanlage
            If .Cells(11, 2) = "" Then
                .Cells(11, 1).Font.Color = RGB(255, 0, 0)
            Else
                .Cells(11, 1).Font.Color = RGB(0, 0, 0)
            End If
          
            'Produziert von
            If .Cells(11, 5) = "" Then
                .Cells(11, 4).Font.Color = RGB(255, 0, 0)
            Else
                .Cells(11, 4).Font.Color = RGB(0, 0, 0)
            End If
          
            'Produziert bis
            If .Cells(11, 9) = "" Then
                .Cells(11, 8).Font.Color = RGB(255, 0, 0)
            Else
                .Cells(11, 8).Font.Color = RGB(0, 0, 0)
            End If
          
        End If
      
        'Meldung ausgeben, dass nicht alle Daten gepflegt sind
        If .Cells(2, 1).Font.Color Or .Cells(3, 1).Font.Color Or _
        .Cells(4, 1).Font.Color Or .Cells(11, 2).Font.Color Or .Cells(11, 4).Font.Color _
        Or .Cells(11, 6).Font.Color = RGB(255, 0, 0) Then
          
            MsgBox "Bitte alle erforderlichen Daten eingeben", vbOKOnly
            LeereStellen = False
          
        Else
      
            LeereStellen = True
      
        End If
      
    End With
  
    Exit Function
  
Namen:
    MsgBox "Bitte die Eingaben prüfen", vbOKOnly
  
End Function
      
Function Ausschussgrund() As Boolean
      
    With Tabelle1
  
        'Meldung ausgeben, dass kein Ausschussgrund angegeben wurde
        If .Cells(22, 3) = False And .Cells(23, 3) = False And .Cells(24, 3) = False And .Cells(25, 3) = False And .Cells(26, 3) = False _
            And .Cells(27, 3) = False And .Cells(28, 3) = False And .Cells(29, 3) = False And .Cells(30, 3) = False And .Cells(31, 3) = False _
            And .Cells(32, 3) = False And .Cells(33, 3) = False And .Cells(34, 3) = False And .Cells(35, 3) = False And .Cells(36, 3) = False _
            And .Cells(21, 4) = False And .Cells(22, 4) = False And .Cells(24, 4) = False And .Cells(25, 4) = False And .Cells(21, 5) = False _
            And .Cells(22, 5) = False And .Cells(23, 5) = False And .Cells(24, 5) = False And .Cells(21, 6) = False And .Cells(22, 6) = False Then
              
            MsgBox "Bitte einen Ausschussgrund auswählen", vbOKOnly
            Ausschussgrund = False
              
        Else
      
            Ausschussgrund = True

        End If
      
    End With

End Function

Private Sub cmdSpeichern_Click()

    Dim strArtikel, strBA, strWerkstoff, strErsteller, strDatum, strVon, strBis, _
        intKategorie, intErkannt, intFertiger, intAnlage, intGut, intAWare, intBWare, intSchrott, intMuster, _
        blnAAusbruch, blnAEinfallstelle, blnAKurzlaenge, blnAMittenversatz, blnALunker, blnARisse, blnAForm, _
        blnAKaltstelle, blnABambus, blnAAnbackeffekt, blnAMaßhaltigkeit, blnAFließlinien, blnASchuppen, _
        blnAAnfahrausschuss, blnBVisko, blnBAnbackeffekt, blnBAusspuelungen, blnBPunkte, blnSFremdkoerper, _
        blnSMetall, blnSUebertempert, blnSVerbrannt, blnMMaß, blnMErstmuster, strEinheit, strBemerkung, _
        blnLeereStellen, blnAusschussgrund, blnAReststueck, intGutProzent, intAWareProzent, intBWareProzent, _
        intSchrottProzent, intMusterProzent, intKW, shQuelle, blnBeendet, strWeiss, strGelb, intAnfahrM, intAnfahrP, _
        intZeile As Integer, blnABindenaht, blnAPoren, blnAFuellung
    Dim wkbZiel As Workbook, wkbDaten As Workbook, wkbQuelle As Workbook

    Application.ScreenUpdating = False
  
    Set wkbQuelle = ThisWorkbook
  
    blnLeereStellen = LeereStellen
    blnAusschussgrund = Ausschussgrund
  
    If blnLeereStellen Or blnAusschussgrund = True Then
      
        'Daten übergeben
        With Tabelle1
      
            strArtikel = .Cells(2, 2)
            strBA = .Cells(3, 2)
            strWerkstoff = .Cells(4, 2)
            strErsteller = .Cells(2, 4)
            strDatum = .Cells(3, 4)
            strVon = .Cells(11, 4)
            strBis = .Cells(11, 6)
            intKategorie = .Cells(6, 6)
            intErkannt = .Cells(10, 6)
            intFertiger = .Cells(10, 5)
            intAnlage = .Cells(11, 2)
            strEinheit = .Cells(16, 1)
            intGut = .Cells(16, 2)
            intGutProzent = .Cells(18, 2)
            intAWare = .Cells(16, 3)
            intAWareProzent = .Cells(18, 3)
            intBWare = .Cells(16, 4)
            intBWareProzent = .Cells(18, 4)
            intSchrott = .Cells(16, 5)
            intSchrottProzent = .Cells(18, 5)
            intMuster = .Cells(16, 6)
            intMusterProzent = .Cells(18, 6)
            strBemerkung = .Cells(43, 1)
            blnAAusbruch = .Cells(25, 3)
            blnAEinfallstelle = .Cells(27, 3)
            blnAKurzlaenge = .Cells(38, 3)
            blnAMittenversatz = .Cells(40, 3)
            blnALunker = .Cells(30, 3)
            blnAPoren = .Cells(31, 3)
            blnASchuppen = .Cells(32, 3)
            blnARisse = .Cells(36, 3)
            blnAForm = .Cells(37, 3)
            blnAFuellung = .Cells(28, 3)
            blnAKaltstelle = .Cells(29, 3)
            blnABambus = .Cells(26, 3)
            blnAAnbackeffekt = .Cells(22, 5)
            blnAMaßhaltigkeit = .Cells(39, 9)
            blnAFließlinien = .Cells(34, 3)
            blnAReststueck = .Cells(41, 3)
            blnAAnfahrausschuss = .Cells(24, 3)
            blnBVisko = .Cells(36, 5)
            blnBAnbackeffekt = .Cells(22, 5)
            blnBAusspuelungen = .Cells(33, 5)
            blnBPunkte = .Cells(34, 5)
            blnSFremdkoerper = .Cells(37, 7)
            blnSMetall = .Cells(38, 7)
            blnSUebertempert = .Cells(34, 7)
            blnSVerbrannt = .Cells(36, 7)
            blnSBW = .Cells(33, 7)
            blnMMaß = .Cells(39, 9)
            blnMErstmuster = .Cells(37, 9)
            blnABindenaht = .Cells(33, 3)
            blnBeendet = .Cells(12, 6)
            strWeiss = .Cells(37, 1)
            strGelb = .Cells(39, 1)
          
            If .Cells(24, 3) = True Then
                intAnfahrM = .Cells(25, 2)
                intAnfahrP = .Cells(26, 2)
            End If
          
        End With
      
        If Tabelle1.Cells(6, 6) <> 4 Then
            On Error GoTo Datei
            Set wkbZiel = GetObject("\\FILE-01\Extrusion\Laufende Produktionen\" & strArtikel & "_BA" & strBA & ".xlsm")
        End If
      
        intZeile = 1
      
        'Datenconainer öffnen und Daten übergeben
        Set wkbDaten = Workbooks.Open("Q:\Qualitätssicherung\Datencontainer\Ausschuss_Extrusion.xlsx")
  
        'Leere Zeile finden
        Do While Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("A" & intZeile) <> ""
            intZeile = intZeile + 1
        Loop
      
        'Daten in die Datei schreiben
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("A" & intZeile) = intZeile - 1
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("B" & intZeile) = strArtikel
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("C" & intZeile) = strBA
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("D" & intZeile) = strWerkstoff
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("E" & intZeile) = intKategorie
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("F" & intZeile) = strErsteller
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("G" & intZeile) = strDatum
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("H" & intZeile) = intErkannt
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("I" & intZeile) = intFertiger
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("J" & intZeile) = intAnlage
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("K" & intZeile) = strVon
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("L" & intZeile) = strBis
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("M" & intZeile) = strEinheit
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("N" & intZeile) = intGut
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("O" & intZeile) = intGutProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("P" & intZeile) = intAWare
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("Q" & intZeile) = intAWareProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("R" & intZeile) = intBWare
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("S" & intZeile) = intBWareProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("T" & intZeile) = intSchrott
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("U" & intZeile) = intSchrottProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("V" & intZeile) = intMuster
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("W" & intZeile) = intMusterProzent
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("X" & intZeile) = strBemerkung
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("Y" & intZeile) = blnAAusbruch
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("Z" & intZeile) = blnAEinfallstelle
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AA" & intZeile) = blnAKurzlaenge
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AB" & intZeile) = blnAMittenversatz
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AC" & intZeile) = blnALunker
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AD" & intZeile) = blnAPoren
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AE" & intZeile) = blnARisse
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AF" & intZeile) = blnAForm
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AG" & intZeile) = blnAFuellung
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AH" & intZeile) = blnAKaltstelle
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AI" & intZeile) = blnABambus
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AJ" & intZeile) = blnAAnbackeffekt
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AK" & intZeile) = blnAMaßhaltigkeit
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AL" & intZeile) = blnAFließlinien
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AM" & intZeile) = blnAReststueck
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AN" & intZeile) = blnASchuppen
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AO" & intZeile) = blnAAnfahrausschuss
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AP" & intZeile) = blnABindenaht
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AQ" & intZeile) = blnBVisko
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AR" & intZeile) = blnBAnbackeffekt
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AS" & intZeile) = blnBAusspuelungen
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AT" & intZeile) = blnBPunkte
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AU" & intZeile) = blnSFremdkoerper
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AV" & intZeile) = blnSMetall
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AW" & intZeile) = blnSUebertempert
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AX" & intZeile) = blnSVerbrannt
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AY" & intZeile) = blnSBW
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("AZ" & intZeile) = blnMMaß
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BA" & intZeile) = blnMErstmuster
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BB" & intZeile) = blnBeendet
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BC" & intZeile) = strWeiss
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BD" & intZeile) = strGelb
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BE" & intZeile) = intAnfahrM
        Workbooks("Ausschuss_Extrusion.xlsx").Sheets("Tabelle1").Range("BF" & intZeile) = intAnfahrP

        'Datencontainer schließen und speichern
        wkbDaten.Close (True)
      
        'Tabellenblatt in Prüfprotokoll von entsprechender BA kopieren (nur bei Extrusion)
        Set shQuelle = ThisWorkbook.ActiveSheet
      
        Tabelle1.Cells(4, 7) = intZeile - 1
      
        If Tabelle1.Cells(6, 6) <> 4 Then
          
            Windows(wkbZiel.Name).Visible = True
            'Hinter letztes Tabellenblatt speichern
            shQuelle.Copy After:=wkbZiel.Sheets(wkbZiel.Sheets.Count)
            'Tebellenblattname ändern und mit KW versehen
            intKW = Format(Date, "ww", 2, 3)
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).Name = "Auschussquittung_KW" & intKW
            'Speichernbutton löschen
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).Shapes.Range(Array("cmdSpeichern")).Delete
            'Benutzernamen und Datumkopieren und als Werte wieder einfügen
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).Range("E2:F3").Copy
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).Range("E2:F3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

            'Protokolldatei speichern
            wkbZiel.Save
          
            'Ausschussquittung ausdrucken
            wkbZiel.Worksheets(wkbZiel.Sheets.Count).PrintOut Copies:=2
          
        Else
      
            'Ausschussquittung drucken SPAN
            wkbQuelle.PrintOut

        End If
      
      
        'Bildschirmaktivität einschalten
        Application.ScreenUpdating = True
      
        'Formulat ohne speichern schließen
        wkbQuelle.Close SaveChanges:=False
  
    End If
  
    Exit Sub
      
Datei:
    MsgBox "Zieldatei nicht gefunden. Bitte Name und Speicherort überprüfen", vbOKOnly, "Zieldatei nicht gefunden"

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

tollertyp · 26. August 2020

Kannst du etwas mehr zum Script sagen, also wie es genutzt wird, was passieren soll?

Das GetObject, soll es ein bestehendes Fenster an der Stelle weiter nutzen oder ein neues Öffnen mit der Datei?

So funktioniert GetObject bei mir übrigens:

Code:

Sub Makro1()

    Dim o As Object
    Set o = GetObject(, "Excel.Application")
    MsgBox "Hallo"

    Set o = GetObject("X:\Downloads\Formelberechnung_Beispiel.xlsm")
    MsgBox "Du"

End Sub

Lasse ich das da weg, funktioniert es nicht mehr:

Code:

    Set o = GetObject(, "Excel.Application")

Edit:
Ich korrigiere, nun funktioniert es auch ohne der Zeile.
Die Datei X:\Downloads\Formelberechnung_Beispiel.xlsm habe ich aber auch geöffnet.
Also das läuft bei mir ohne Fehler durch

Code:

Sub Makro1()

    Dim o As Object
    Set o = GetObject("X:\Downloads\Formelberechnung_Beispiel.xlsm")

End Sub

obwohl es Backslashes hat.
Ist die Datei geschlossen, wird sie nu bei mir geöffnet, wenn ich das Makro starte.

Vorher:

Nach Ausführung des Markos

Und ich wiederhole:

Und dein On Error verschleiert halt die Stelle, wo der Fehler passiert ist.

Kommentier die Stelle mal zum Testen aus und schau, wo der Fehler passiert.

@Wurzelsepp29: Gruselig ist es, irgendwelche Vermutungen in den Raum zu werfen ohne zurückzurudern, die nichts anderes als Nebelkerzen sind, und Beispiele für eine schlechte Dokumentation zu liefern, die nichts mit der Dokumentation zu tun haben, sondern eher mit einem Bug zu tun haben?

Das Worksheet-Protect funktioniert im Übrigen bei mir wunderbar in VBA.

Sperrt Tabelle1 wunderbar:

Aber bestimmt nur, weil man die Dokumentation aktualisiert hat ... an den Kopf lang

Althir81 · 26. August 2020

Okay, habe den On Error mal auskommentiert, bekomme nun einen Laufzeitfehler 432..
Datei- oder Klassenname während Automatisierungsoperation nicht gefunden...

Ich schau jetzt erstmal weiter im Detail...

jedenfalls wirft er dann beim debuggen folgendes aus

Wurzelsepp29 · 26. August 2020

tollertyp schrieb:
Das Worksheet-Protect funktioniert im Übrigen bei mir wunderbar in VBA.
Anhang anzeigen 958947
Sperrt Tabelle1 wunderbar:

Führe das Protect 2x aus und schau ob du dann die Zelle bearbeiten kannst und was im Ribbon steht

Althir81 · 26. August 2020

Okay, ich hab jedenfalls meine Probleme lösen können. Danke jedenfalls.
Mir wurde der Ablauf falsch mitgeteilt. Pfadangaben funktionieren so.

tollertyp · 26. August 2020

Alles klar.
Würde dann auf jeden Fall das On Error wieder reinnehmen, falls du es nicht schon hast. Die meisten Nutzer wären mit dem VBA-Editor überfordert.

@Wurzelsepp29: Was mache ich falsch?

Das Video muss man leider runterladen, funktioniert eingebettet irgendwie nicht.

Althir81 · 26. August 2020

tollertyp schrieb:
Alles klar.
Würde dann auf jeden Fall das On Error wieder reinnehmen, falls du es nicht schon hast. Die meisten Nutzer wären mit dem VBA-Editor überfordert.

@Wurzelsepp29: Was mache ich falsch?

Das Video muss man leider runterladen, funktioniert eingebettet irgendwie nicht.

Ja habe ich wieder reingepackt.... :-)

Suche

Excel (VBA GetObject) Netzwerkpfad

Althir81

Lieutenant

Wurzelsepp29

Lt. Junior Grade

tollertyp

Fleet Admiral

Althir81

Lieutenant

Wurzelsepp29

Lt. Junior Grade

Althir81

Lieutenant

tollertyp

Fleet Admiral

Althir81

Lieutenant

Wurzelsepp29

Lt. Junior Grade

Althir81

Lieutenant

tollertyp

Fleet Admiral

Anhänge

Althir81

Lieutenant

Ähnliche Themen