Tabellenblätter per Knopfdruck

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Schaltfläche1_Klicken() Dim TBG As Worksheet, TB1 As Worksheet, TBx As Worksheet Dim NeuName As String, LR As Integer Set TBG = Sheets("Geräteübersicht") Set TB1 = Sheets("1") 'Neue Nummer NeuName = WorksheetFunction.Max(TBG.Columns(1)) + 1 ' **Neue Zeile LR = TBG.Cells(TBG.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte '**Prüfen ob Blatt schon da If IsError(Evaluate(NeuName & "!A1")) Then 'Nein, neues Blatt anlegen TB1.Copy After:=Sheets(Sheets.Count) Set TBx = ActiveSheet With TBx '**benennen .Name = NeuName '**Neue Nummer in Übersicht einfügen TBG.Cells(LR + 1, 1) = NeuName '**Link in Übersicht einfügen TBG.Hyperlinks.Add Anchor:=TBG.Cells(LR + 1, 8), Address:="", SubAddress:= _ "'" & NeuName & "'!A1", TextToDisplay:="'" & NeuName & "'!A1" '**Formeln einfügen .Cells(3, 1).Resize(1, 2).FormulaR1C1 = "=" & TBG.Name & "!R" & LR + 1 & "C" .Cells(3, 3).Resize(1, 3).FormulaR1C1 = "=" & TBG.Name & "!R" & LR + 1 & "C[1]" End With Else MsgBox NeuName & ": existiert bereits" End If End Sub

Hallo nochmal
hab gerade gesehen, da sind ja noch weitere Verbundene Zellen.
Also Formelzuweisung in 3 Schritten

Option Explicit
Sub Schaltfläche1_Klicken()
    Dim TBG  As Worksheet, TB1  As Worksheet, TBx As Worksheet
    Dim NeuName As String, LR As Integer
    
    Set TBG = Sheets("Geräteübersicht")
    Set TB1 = Sheets("1")
        
    'Neue Nummer 
    NeuName = WorksheetFunction.Max(TBG.Columns(1)) + 1
    
    ' **Neue Zeile 
    LR = TBG.Cells(TBG.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte 

    '**Prüfen ob Blatt schon da 
    If IsError(Evaluate(NeuName & "!A1")) Then
        'Nein, neues Blatt anlegen 
        TB1.Copy After:=Sheets(Sheets.Count)
        Set TBx = ActiveSheet
        

        With TBx
            '**benennen 
            .Name = NeuName
        
            '**Neue Nummer in Übersicht einfügen 
            TBG.Cells(LR + 1, 1) = NeuName
        
            '**Link in Übersicht einfügen 
            TBG.Hyperlinks.Add Anchor:=TBG.Cells(LR + 1, 8), Address:="", SubAddress:= _
                "'" & NeuName & "'!A1", TextToDisplay:="'" & NeuName & "'!A1"
            
            'GGF **Neue Zeile ergänzen 
            TBG.Rows(LR + 2).Copy
            TBG.Rows(LR + 2).Insert xlDown
            Application.CutCopyMode = False

            
            '**Formeln einfügen 
            .Cells(3, 1).Resize(1, 2).FormulaR1C1 = "=" & TBG.Name & "!R" & LR + 1 & "C"
            .Cells(3, 3).Resize(1, 1).FormulaR1C1 = "=" & TBG.Name & "!R" & LR + 1 & "C[1]"
            .Cells(3, 4).Resize(1, 2).FormulaR1C1 = "=" & TBG.Name & "!R" & LR + 1 & "C[2]"
        
        End With
    Else
        MsgBox NeuName & ": existiert bereits"
        
    End If
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread