Office: (Office 2016) Nächste Leere Zeile statt Letzte Zeile finden

Servus Zusammen,

Ich benutze aktuell folgende Codezeile um in einer Matrix die letzte Leere Zeile zu finden.
LZeile = Sheets("Interna").Cells(Rows.Count, "B").End(xlUp).Row + 1

Die liste besteht aus Teilnehmern, bei denen durchaus aber auch mal jemand absagt.
Damit der dann leere Platz wieder befüllt werden kann, möchte ich mit dem Macro also nicht die Letzte Leere Zeile finden, sondern die nächste Leere Zeile.
Die Matrix liegt im Bereich B7:E28, wobei die Zeile 7 mit Überschriften Belegt ist.

Kann mir jemand sagen wie ich das also Umformulieren muss ?

Das ergebnis (LZeile) wird wiederum als Variable genutzt um in der Zeile dann Daten einzufügen.

Vielen Dank uns habt nen schönen Tag

Gruß
Eddy

 

Hi Eddy,

das kann man in einer Do-Loop-Schleife realisieren:

Code:

Sub ErsteLeere()
    Dim lngZeile As Long
    lngZeile = 7
    With Sheets("Interna")
        Do
            If .Cells(lngZeile, 2) = "" Then
                MsgBox "Erste leere Zelle ist " & lngZeile
                Exit Sub
            End If
            lngZeile = lngZeile + 1
        Loop While lngZeile < .Cells(Rows.Count, "B").End(xlUp).Row
    End With
End Sub

---

 

Hallo Beverly,

vielen Dank für deine Antwort.
Leider habe ich noch nicht die Option hier gefunden um meinen Code hier in dem Extra-Fenster wie bei dir darzustellen.
Würde ich ihn hier normal einfügen, wäre das wohl sehr unübersichtlich, da er von mir wahrscheinlich extrem "unordentlich" erstellt wurde.
Ich erstelle u.a. einen Automatischen Kalenderbucheintrag und eine Mail die beide automatisch befüllt und versendet bzw. gespeichert werden.

Der Part den ich fürs finden und einfügen nutze sieht wie folgt aus:
*snip*
Dim LZeile
LZeile = Sheets("Interna").Cells(Rows.Count, "B").End(xlUp).Row + 1
Sheets("Seminaranmeldung").Range("B8:E8").Copy
Worksheets("Interna").Range("B" & LZeile).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
Sheets("Seminaranmeldung").Range("B8:E8").ClearContents
*snip*

Gruß
Eddy

 

Hi Eddy,

wenn du die Icons oberhalb des Antwortfensters anschaust siehst du ziemlich weit rechts ein Diskettensymbol und links daneben so etwas wie ein teilweise beschriebenes Blatt - wenn du dieses Icon klickst erhältst du 4 Auswahlmöglichkeiten - u.a. eben auch "Code". Wenn du dann diese klickst erscheint ein extra Fensterchen, wo du deinen Code einfügen kannst.

Und wo ist nun das Problem?

---

 

Hallo Beverly,

nochmals danke für den Hinweis. Mein Problem besteht darin das ich ziemlich neu in VBA bin und aktuell nicht wüsste wie ich den Passus von dir in meinen Code einbaue.
Dieser sieht so aus.

Code:

Sub Seminarplatz_I_reservieren()


    If ActiveSheet.Range("B8").Text = "" Then
        MsgBox "Bitte tragen Sie Ihren Namen und Vornamen ein.", vbCritical
    Exit Sub
    End If
   
    If ActiveSheet.Range("C8").Text = "" Then
        MsgBox "Bitte tragen Sie Ihre Dienstl. E-Mailadresse ein.         " & _
        "    Wichtig: Kein Teampostfach!! ", vbCritical
    Exit Sub
    End If
   
    If ActiveSheet.Range("D8").Text = "" Then
        MsgBox "Bitte tragen Sie Ihren Standort ein.", vbCritical
    Exit Sub
    End If
 
   If ActiveSheet.Range("E8").Text = "" Then
        MsgBox "Bitte tragen Sie Ihre Teamkennung ein.", vbCritical
    Exit Sub
    End If
   
    If Sheets("Interna").Range("D4") = Sheets("Interna").Range("D3") Then
         MsgBox "Maximale Teilnehmerzahl erreicht! " & _
         "Reservierung nicht möglich. ", vbExclamation, "Hinweis"
         Sheets("Seminaranmeldung").Range("B8:D8").ClearContents
 Exit Sub
 End If
   
   
    ' SET Outlook APPLICATION OBJECT.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
   
    ' CREATE EMAIL OBJECT.
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(olMailItem)
   
    Set Appointtermin = objOutlook.CreateItem(1)
       
   
   

    With Appointtermin
         .Subject = Sheets("Seminaranmeldung").Range("F1").Value
         .Start = Sheets("Seminaranmeldung").Range("C4").Value
         .End = Sheets("Seminaranmeldung").Range("D4").Value
         .Location = Sheets("Interna").Range("J1").Value
         .Body = Sheets("Seminaranmeldung").Range("B3").Value
         .AllDayEvent = False
         .ReminderMinutesBeforeStart = 15
         .ReminderPlaySound = True
         .ReminderSet = True
         .Display
 '        .Save
 
    MsgBox "Termin wurde als Erinnerung in Ihrem Outlookkalender eingetragen. ", vbOKOnly
   
End With

    With objEmail
        .To = Sheets("Mailformat").Range("D7").Value
        .cc = Sheets("Mailformat").Range("D9").Value
        .Subject = "Reservierung " & Range("F1").Value
        .Body = Sheets("Mailformat").Range("D12").Value & Chr(13) & _
                " " & Chr(13) & _
                Sheets("Mailformat").Range("D14").Value & Chr(13) & _
                Sheets("Mailformat").Range("D15").Value & Chr(13) & _
                Sheets("Mailformat").Range("D16").Value & Chr(13) & _
                Sheets("Mailformat").Range("D17").Value & Chr(13) & _
                Sheets("Mailformat").Range("D18").Value & Chr(13) & _
                Sheets("Mailformat").Range("D19").Value & Chr(13) & _
                Sheets("Mailformat").Range("D20").Value & Chr(13) & _
                Sheets("Seminaranmeldung").Range("B3").Value & Chr(13) & _
                Sheets("Seminaranmeldung").Range("B4").Value & Chr(13) & _
                Sheets("Seminaranmeldung").Range("B5").Value & " bis " & Sheets("Seminaranmeldung").Range("D5") & " Uhr" & Chr(13)

        .Display
'        .Send
    End With
   
    ' CLEAR.
    Set objEmail = Nothing:    Set objOutlook = Nothing
    Set OL = Nothing

    Dim LZeile
 LZeile = Sheets("Interna").Cells(Rows.Count, "B").End(xlUp).Row + 1
' Sheets("Seminaranmeldung").Range("B8:E8").Copy _
'   Destination:=Sheets("Interna").Range("B" & LZeile & ":E" & LZeile)
Sheets("Seminaranmeldung").Range("B8:E8").Copy
Worksheets("Interna").Range("B" & LZeile).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
    Sheets("Seminaranmeldung").Range("B8:E8").ClearContents
 
ActiveWorkbook.Save

 

End Sub

Der Rest des Codes funktionier soweit gut. In der Finalen Version werde ich noch ändern, das der Kalendereintrag automatisch gespeichert wird.
Aber sonst klappt der Code. Ich hatte beim erstellen und zusammenbauen nur die Wahrscheinlichkeit vergessen das ja auch Mitarbeiter ihre Reservierung stornieren und dann eben nicht der Letzte Platz, sondern einer zwischen drinne frei wird.
Das möchte ich damit nun noch anpassen.


Vielen Dank für deine Zeit

Gruß
Eddy

 

Hi Eddy,

nach deiner Zeile Set OL = Nohting anstelle deines Kopiercodes diesen setzen:

Code:

    Dim lZeile As Long
    lZeile = 7
    With Sheets("Interna")
        Do
            If .Cells(lZeile, 2) = "" Then
                Sheets("Seminaranmeldung").Range("B8:E8").Copy .Cells(lZeile, 2)
                Exit Sub
            End If
            lZeile = lZeile + 1
        Loop While lZeile < .Cells(Rows.Count, "B").End(xlUp).Row
        Sheets("Seminaranmeldung").Range("B8:E8").Copy .Cells(lZeile + 1, 2)
    End With

Was in dem Code abläuft ist dir plausibel, oder hast du Fragen dazu?

---

 

Hallo Beverly,

der Code ist für mich im großen und ganzen Plausibel zu lesen ja :) Nur beim Schreiben habe ich noch so meine Probleme.
Wie es halt bei alles Sprachen so ist. Verstehen ist meistens leichter zu lernen als sie zu sprechen/schreiben.


Bei deinem Code wird auch die Formatierung der Zelle kopiert oder ?

Das würde ich noch Anpassen, da die Zellen auf den beiden Tabellenblättern z.B. unterschiedliche Farben haben.

Ich danke dir Vielmals

Wünsche dir einen schönen Tag und bleib Gesund

Gruß
Eddy

 

Guten Morgen,
ich habe de Code jetzt wie unten zu sehen angepasst und er funktioniert perfekt.
Ich danke dir Vielmals

Gruß
Eddy

Code:

Dim lZeile As Long
    lZeile = 7
    With Sheets("Interna")
        Do
            If .Cells(lZeile, 2) = "" Then
                Sheets("Seminaranmeldung").Range("B8:E8").Copy '.Cells(lZeile, 2)
                Worksheets("Interna").Range("B" & lZeile).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlPasteSpecialOperationNone
                Sheets("Seminaranmeldung").Range("B8:E8").ClearContents
                Exit Sub
            End If
            lZeile = lZeile + 1
        Loop While lZeile < .Cells(Rows.Count, "B").End(xlUp).Row
        Sheets("Seminaranmeldung").Range("B8:E8").Copy '.Cells(lZeile + 1, 2)
    Worksheets("Interna").Range("B" & lZeile).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
    Sheets("Seminaranmeldung").Range("B8:E8").ClearContents
End With
ActiveWorkbook.Save