Brauche Hilfe bei einer VBA

[Philippste91]

Hi ihr lieben ich brauche einmal Hilfe für eine VBA.
Habe meine Tabelle mal angehangen. 
Ich möchte, dass bei der VBA das Datum sich in jeder Zeile in B anpasst und nicht nur in B2. Habt ihr eine Idee?


Sub Test()



    Dim SheetNameAlt As String

    Dim SheetNameNeu As String

 

    'Letztes Sheet wählen

    Sheets(Sheets.Count).Select

    SheetNameAlt = Sheets(Sheets.Count).Name    'Namen merken

 

    'Letztes Sheet kopieren und ans Ende setzen

    Sheets(Sheets.Count).Copy After:=Sheets(Sheets.Count)

     

    'Selektiere Sheet "Datum"

    Sheets("Datum").Select

 

    'Selektiere Zelle aus Sheet "Datum" mit Zellwert = Sheetname

    'Selektiere nächste Zeile

    'Zellwert aus Selektion = Sheetname neues Sheet

    For Each c In [A:A]

        If c.Value Like SheetNameAlt Then

            c.Select

            ActiveCell.Offset(1, 0).Select

        End If

        SheetNameNeu = ActiveCell.Value 'Neuen Sheet-Namen merken

    Next

   

    'Letzes Sheet wählen

    Sheets(Sheets.Count).Select

 

    'Neues Sheet umbennnen

    Sheets(Sheets.Count).Name = SheetNameNeu

 

    'Formel in Zelle B2 anpassen

    'Referenz auf vorheriges Sheet

    Range("B2:B246").Select

    ActiveSheet.Unprotect

    ActiveCell.FormulaR1C1 = "='" & SheetNameAlt & "'!RC[14]"

    ActiveSheet.Protect



End Sub

---

[HKindler]

Hi,

verwende das nächste mal bitte Code-Tags. Und statt Bildern ist eine Excel-Datei wesentlich sinnvoller.

Ganz kurze Lösung: ersetze ActiveCell.FormulaR1C1 durch Selection.FormulaR1C1

Und so ganz nebenbei, verzichtet man auf Select etc. wird der Code gleich viel Kürzer, schneller und übersichtlicher. Außerdem sollte man ALLE Variablen deklarieren. Dazu am Besten Option Explicit verwenden.

Code:

Sub Test()
    Dim SheetNameAlt As String
    Dim SheetNameNeu As String
    Dim c As Range
    SheetNameAlt = Sheets(Sheets.Count).Name
    Sheets(Sheets.Count).Copy After:=Sheets(Sheets.Count)
    For Each c In Sheets("Datum").Range("A: A")
        If c.Value Like SheetNameAlt Then
            SheetNameNeu = c.Offset(1, 0).Value
            Exit For
        End If
    Next
    With Sheets(Sheets.Count)
        .Name = SheetNameNeu
        .Unprotect
        .Range("B2:B246").FormulaR1C1 = "='" & SheetNameAlt & "'!RC[14]"
        .Protect
    End With
End Sub

[Ralf A]

...wunder, wunder, wunder....

Mensch Helmut,

dass Du diesen Quatsch mitmachst? Hast Du heute die Cannabisfreigabe genutzt? (Natürlich nur aus rein gesundheitlichen Gründen...  ), oder bist Du heute besonders nachsichtig? 
Sonst empfiehlst doch immer (und zwar zu Recht) alle Daten in eine Tabelle...
Und mit einer Auswertung via Pivot kann man sich die ganzen Klimmzüge sparen...

[HKindler]

Ab und zu habe ich einfach keine Lust Leute bekehren zu wollen. Ist meist sowieso vergebene Liebesmüh.
Und dann sieht mir das Bildchen nach Kassenbuch oder so etwas aus. Da ist mir die Mühe erst recht zuviel, die Leute von einer anderen Arbeitsweise zu überzeugen.

Und Cannabis habe ich noch nie benutzt und werde ich auch wohl nie benutzen - bin froh dass ich von den normalen Glimmstängeln seit 3.433 Tagen weg bin. Da nehme ich doch lieber ein Glas Rotwein.

[Gast 123]

Hallo

ich weiss ja nicht wozu das ganze gut sein soll, aber alle drei Tage ein neues Sheet macht im Jahr 122 Sheets.
Da wäre es wirklich klug den Frager aufmerksam zu machen, das man alle Daten untereinander setzen kann.
Das wäre dann ein einziges Sheet für ein ganzes Jahr.  Ob er das möchte, ist natürlich ungewiss.
(Schuster bleiben gerne bei Ihren alten Schuhen, selbst wenn sie abgelatscht und löcherig sind!)

Glimmstengel ist auch ein Sorgenkind (nicht mehr bei mir) und  Rotwein ist eine schöne Sache.
Freue ich mich drauf wenn ich wieder mal in Deutschland bin.  In diesem Sinne ....

mfg Gast 123

---

Naschtrag:  sein langer Code mit Select könnte auch so laufen:

Code:

Sub Neues_Sheet()
    Dim SheetNameAlt As String
    Dim SheetNameNeu As String
    'Letztes Sheet Namen merken
    SheetNameAlt = Sheets(Sheets.Count).Name

    For Each C In [A:A]
        If C.Value Like SheetNameAlt Then
           SheetNameNeu = C.Offset(1, 0).Value
           Exit For
        End If
    Next C
   
    'Letztes Sheet kopieren und ans Ende setzen
    Sheets(Sheets.Count).Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = SheetNameNeu

    With Sheets(SheetNameNeu)
        .Unprotect
        .FormulaR1C1 = "='" & SheetNameAlt & "'!RC[14]"
        .Protect
    End With
End Sub

[Philippste91]

Vielen dank für die schnelle Hilfe.
Bin nur ein Feuerwehrmann und versuche mich gerade erst mit Excel und VBA deshalb bitte ein bisschen Nachsicht.
Funktioniert einwandfrei daher vielen danke