Office: Prüfung unterschiedlicher Zellen auf Inhalt und Konsequenz

Hallo zusammen,

ich habe einen Code, bei dem ich mehrere voneinander getrennte Zellen auf Befüllung prüfe.
Wenn ich mindestens eine nicht befülle, erscheint eine Fehlermeldung und das Script bricht ab.

Soweit so gut.
Sind jetzt aber alle befüllt, dann soll die Datei gespeichert werden. Diesen Tel führt das Script aber leider nicht aus.

Code:

Dim rg As Range, cb As String



Set wkbQuelle = ActiveWorkbook

'Prüfung ob Muss-Felder gefüllt

    Set rg = ActiveSheet.Range("F40,H40,F42,H42,F52,H52,F54,H54,F157,H157,G160")
    
        If rg.SpecialCells(xlCellTypeBlanks).Count = rg.Count Then
        
                'Datei unter neunem Namen speichern
                cb = InputBox("Bitte Dateinamen im Format 'Antrag_Antragsgegenstand_Namenskürzel' angeben")

                 ChDrive "J:\"
                 ChDir "J:\03_Allgemeine Themen\06_Freigabeworkflow neue Materialien\\Arbeitsverzeichnis\"
                    ActiveWorkbook.SaveAs Filename:=cb _
                    , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        Else
            MsgBox "Bitte füllen Sie alle Mussfelder (*) aus.", vbCritical, "Fehler"
            Exit Sub
            
        End If

Interessant ist, dass der Wert der freien Zellen bei Befüllung aller relevanten Zellen als 4 zurück gegeben wird. Es erscheint auch die Meldung


Also ist die Prüfung okay, aber warum springt das Script nicht in die Bedingung?

 

Es macht auch keinen Unterschied ob ich die Bedingung ändere, z.B. in

Code:

rg.SpecialCells(xlCellTypeBlanks).Count = 0 Then

oder mit <> rg.count

 

Hi,

versuche es mal so:

Code:

    Dim rg As Range, cb As String, wkbQuelle As Workbook
    Dim intAnzahl As Integer
    Set wkbQuelle = ActiveWorkbook
    Set rg = ActiveSheet.Range("F40,H40,F42,H42,F52,H52,F54,H54,F157,H157,G160")
    'Prüfung ob Muss-Felder gefüllt
    On Error Resume Next
    intAnzahl = rg.SpecialCells(xlCellTypeBlanks).Count
    On Error GoTo 0
    If intAnzahl = 0 Then
        'Datei unter neunem Namen speichern
        cb = InputBox("Bitte Dateinamen im Format 'Antrag_Antragsgegenstand_Namenskürzel' angeben")
         ChDrive "J:\"
         ChDir "J:\03_Allgemeine Themen\06_Freigabeworkflow neue Materialien\\Arbeitsverzeichnis\"
            ActiveWorkbook.SaveAs Filename:=cb _
            , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Else
        MsgBox "Bitte füllen Sie alle Mussfelder (*) aus.", vbCritical, "Fehler"
    End If

---

 

Super, funktionier perfekt, danke Dir