keine freien Zellen erlauben

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: keine freien Zellen erlauben
von: Stefan
Geschrieben am: 02.06.2015 08:46:02

Hi ihr Spezis :)
ich würde gern per VBA verbieten lassen, dass in einer Spalte eine freie Zelle entsteht. Sodass man gezwungen ist in die erste freie Zelle etwas einzutragen.
Bisher bin ich leider nur gescheiter :(

Dim Ende As Long
With ActiveSheet
Ende = .Cells(Rows.Count, 7).End(xlUp).Row
End With

If Cells(Ende + 1, 7).Value = "" And Cells(Ende + 2, 7).Value <> "" Then
MsgBox ("oh oh")

Else
...Makro
End Sub
Wäre super, wenn ihr einen Ansatz hättet!
Danke!!!
Stefan

Bild

Betrifft: AW: keine freien Zellen erlauben
von: Hajo_Zi
Geschrieben am: 02.06.2015 08:56:36
Hallo Stefan,
starte den VBA Editor (Alt+F11), Bild sollte zweigeteilt sein ansonsten Strg+R, Doppelklick auf Deine Datei, Doppelklick auf Deine Tabelle, Code ins rechte Fenster kopieren, VBA Editor schließen.
Das Makro wird automatisch gestartet.
Der Code wirkt nur in dieser Tabelle.

Option Explicit                                     ' Variablendefinition erforderlich
Private Sub Worksheet_Change(ByVal Target As Range)
    '***********************************************
    '* H. Ziplies                                  *
    '* 02.06.15                                    *
    '* erstellt von HajoZiplies@web.de             *
'* http://Hajo-Excel.de/
 *
    '***********************************************
    Dim RaBereich As Range                          ' Variable für Bereich
    Dim RaZelle As Range                            ' Variable für Zelle
    Set RaBereich = Range("C:C")                    ' Bereich der Wirksamkeit
    ' noch mehr Bereiche
    'Set RaBereich = Union(Range("C11:AG11 , C13:AG13, C15:AG15 , C17:AG17"), _
    '    Range("C35:AE35, C37:AE37, C43:AG43, C45:AG45 , C47:AG47 , C49:AG49"), _
    '    Range("C67:AF67 , C69:AF69 , C75:AG75 , C77:AG77 , C79:AG79 , C81:AG81"), _
    '    Range("C99:AF99 , C101:AF101, C107:AG107 , C109:AG109 , C111:AG111"), _
    '    Range("C127:AG127 , C129:AG129 , C131:AG131 , C133:AG133 , C139:AF139"), _
    '    Range("C155:AG155, C157:AG157 , C159:AG159 , C161:AG161 , C163:AG163"), _
    '    Range("C179:AF179 , C181:AF181, C187:AG187 , C189:AG189 , C191:AG191"))
    ' ab Vesion XP braucht der Schutz nicht aufgehoben werden
    ' Formatierung bei Schutz kann über Dialog Schutz eingestellt werden
    ' Zelle die in dem Bereich liegen auf die Variable schreiben
    ' damit werden nur noch die Zellen bearbeitet die im vorgegeben Bereich liegen
    ' jede Zelladresse ist einzeln angegeben
    Set RaBereich = Intersect(RaBereich, Range(Target.Address))
    If Not RaBereich Is Nothing Then
        'ActiveSheet.Unprotect ("Passwort")
        For Each RaZelle In RaBereich
            With RaZelle
                If RaZelle.Row > 1 Then
                    If RaZelle.Offset(-1, 0) = "" And RaZelle <> "" Then
                        MsgBox "keine leeren Zellen"
                        Application.EnableEvents = False
                        Application.Undo
                        Application.EnableEvents = True
                    End If
                End If
            End With
        Next RaZelle
        'ActiveSheet.protect ("Passwort")
    End If
    Set RaBereich = Nothing                         ' Variable leeren
End Sub


Bild

Betrifft: AW: keine freien Zellen erlauben
von: Stefan
Geschrieben am: 02.06.2015 09:07:52
Hallo Hajo,
Vielen Dank!!!!!!!! Funktioniert einwandfrei!
Grüße,
Stefan

Bild

Betrifft: damit kann man aber ...
von: Rudi Maintaire
Geschrieben am: 02.06.2015 10:31:39
Hallo,
Zellen mittendrin löschen!
Und zu lang ist der Code auch.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range
  If Target.Column = 7 And Target.Row > 1 Then
    On Error GoTo ERREXIT
    Set r = Range(Cells(1, 7), Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeBlanks)
    If Not r Is Nothing Then
      Application.EnableEvents = False
      MsgBox "oh oh"
      Application.Undo
      Application.EnableEvents = True
    End If
  End If
ERREXIT:   
  Application.EnableEvents = True
End Sub

Gruß
Rudi

Bild

Betrifft: AW: keine freien Zellen erlauben
von: UweD
Geschrieben am: 02.06.2015 09:39:39
Hallo
- Rechtsclick auf den Tabellenblattreiter
- Code anzeigen
- Makro reincopieren

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Fehler
    Dim Ende As Long, ZE As Integer, Sp As Integer
    ZE = 2 ' erste Zeile, ggf Überschrift beachten
    Sp = Target.Column 'aktuelle Spalte
    With ActiveSheet
        Ende = .Cells(Rows.Count, Sp).End(xlUp).Row
        If WorksheetFunction.CountA(Range(.Cells(ZE, Sp), .Cells(Ende, Sp))) <> Ende - ZE + 1  _
Then
            MsgBox ("Es sind leere Zellen vorhanden")
            With Application
                .EnableEvents = False
                .Undo
            End With
        Else
        '...Makro
        End If
    End With
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
    Application.EnableEvents = True
End Sub

Gruß UweD

Bild

Betrifft: AW: Lösung mit Gültigkeit
von: UweD
Geschrieben am: 02.06.2015 09:54:17
...
Beispiel für A2: (Überschrift vorrausgesetzt)
- Daten, Datenüberprüfung,
- Zulassen: Benutzerdefiniert
- Formel: =ANZAHL2(A$2:A2)=ZEILE()-1
- Bei Fehlermeldung den passenden Kommentar eintragen.
- dann die Gültigkeit auf alle Zellen "Kopieren"
- A2 kopieren
- Bereich markieren
- Inhalte Einfügen, Gültigkeiten
Gruß UweD

 Bild

Beiträge aus den Excel-Beispielen zum Thema "keine freien Zellen erlauben"