VBA: Zelleninhalte per Button in Liste kopieren

[sorrowed]

Guten Tag an alle,

Nach längerem suchen im Forum bin ich leider nicht auf eine Lösung für mein Problem gestoßen, obwohl es diese Frage bestimmt schon zu genüge gab.


Ich möchte den Vor- und Nachnamen eines Mitarbeiters per Buttonklick in eine Liste übertragen. Diese Liste soll eine fortlaufende Nummer haben die mit dem Buttonklick automatisch hochgezählt wird. Der Anfang von allem sieht bei mir so aus:

Code:

Sub Eintragen()
   
    Dim Vorname As String, Nachname As String
    Worksheets("Mitarbeiter").Select
    Vorname = Range("B2")
   
    Worksheets("Admin").Range("B9").Select
   
    If Worksheets("Mitarbeiter").Range("B9").Offset(1, 0) <> "" Then
        Worksheets("Mitarbeiter").Range("B9").End(xlDown).Select
    End If

    ActiveCell.Offset(1, 0).Select
    ActiveCell.Value = Vorname

End Sub

Meine angegebenen Inhalte werden zwar in die Zelle kopiert, aber nicht fortlaufend weitergeführt. Die Funktion für das hochzählen der ID fehlt noch komplett, da ich nicht weiß wie ich das am einfachsten umsetze.
Der Einfachhaltshalber beim Testen ist die Liste auf dem selben Worksheet, das soll später nicht so umgesetzt werden.


Vielen Dank für die Hilfe und bleibt gesund,
Fabian

[Oberschlumpf]

Hi Fabian,

im Anhang siehst du, was ich erfolglos versucht habe.

Ciao
Thorsten

[Fuzzy62]

Hallo Fabian,

versuch es mal damit,

Code:

Option Explicit

Sub Eintragen() ' ID, Vorname und Name in Tabelle einfügen
Dim Vorname As String, Nachname As String
Dim intLastRow As Integer, z As Integer
Dim rngBereich As Range

'Variable füllen
Vorname = Worksheets("Tabelle1").Range("B2").Value
Nachname = Worksheets("Tabelle1").Range("B3").Value

' Erste frei Zeile
intLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1

' Größte Zahl in Spalte ID ermitteln
Set rngBereich = Range(Cells(9, 1), Cells(intLastRow, 1))

z = WorksheetFunction.Max(rngBereich)

    If Cells(intLastRow - 1, 1) < 1 Then
        Cells(intLastRow, 1).Value = 1
        Cells(intLastRow, 2).Value = Vorname
        Cells(intLastRow, 3).Value = Nachname
    Else
        Cells(intLastRow, 1).Value = z + 1
        Cells(intLastRow, 2).Value = Vorname
        Cells(intLastRow, 3).Value = Nachname
    End If
Range("B2:B3").Clear
End Sub

und für's nächste mal, füge eine Beispielsdatei mit aussagekräftigen Namen ein und keine Grafik!

[sorrowed]

Hallo Klaus,

Vielen dank für deinen Hinweis mit dem Hochladen der Datei, das war mir unbekannt. 
Ich bin froh zu sehen, dass es hier auch Erwachsene gibt die solche Versäumnisse normal ansprechen können und nicht denken dass ihre unreifen Kommentare zu einer Lösung führen. /offtopic


Deine Lösung brachte das richtige Ergebnis, ich setze das Thema als erledigt. In der Zwischenzeit bin ich selbst zu einer Lösung gekommen, ich werde sie hier mal posten falls jemand Interesse daran hat. Deine sieht mir aber besser aus.

Code:

Sub Eintragen_Klick()
   
    Dim Vorname As String, Nachname As String
    Dim num As Integer
    Vorname = Range("B2")
    Nachname = Range("B3")
   
    Worksheets("Tabelle1").Select

    If IsEmpty(Worksheets("Tabelle1").Range("B2").Value) = True Or IsEmpty(Worksheets("Tabelle1").Range("B3").Value) = True Then
        MsgBox ("Bitte Vollständig ausfüllen!")
    Else
        Worksheets("Tabelle1").Range("B8").Select
       
        If Worksheets("Tabelle1").Range("B8").Offset(1, 0) <> "" Then
            Worksheets("Tabelle1").Range("B8").End(xlDown).Select
        End If

        ActiveCell.Offset(1, -1).Select
       
        'Beginn der Schleifenzählung starten
        If ActiveCell.Value = "" Then
            ActiveCell.Offset(-1, 0).Select
            num = ActiveCell.Value
           
            ActiveCell.Offset(1, 0).Select
            ActiveCell.Value = num + 1
        End If
       
        'Werte eintragen
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = Vorname

        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = Nachname

        Worksheets("Tabelle1").Range("B2:B3").Clear
    End If
   
End Sub

Danke und Gruß,
Fabian

[Fuzzy62]

Hallo Fabian,

ich habe dein Makro etwas angepasst!

du kannst meistens auf die Anweisung SELECT verzichten!

Code:

Sub Eintragen_Klick()
Dim Vorname As String, Nachname As String
Dim num As Integer

Vorname = Range("B2")
Nachname = Range("B3")
   
With Worksheets("Tabelle1")
    If IsEmpty(.Range("B2").Value) = True Or _
        IsEmpty(.Range("B3").Value) = True Then
        MsgBox ("Bitte Vollständig ausfüllen!")
    Else

        If .Range("B8").Offset(1, 0) <> "" Then
            .Range("B8").End(xlDown).Select
        End If
      
        'Beginn der Schleifenzählung starten
        If ActiveCell.Offset(1, -1).Value = "" Then

            num = ActiveCell.Offset(0, -1).Value

            ActiveCell.Offset(1, -1).Value = num + 1
        End If
      
        'Werte eintragen
        ActiveCell.Offset(1, 0).Value = Vorname
        ActiveCell.Offset(1, 1).Value = Nachname

        .Range("B2:B3").Clear
    End If
End With
End Sub