Rij met formules automatisch kopieeren

[bowlingman]

Ik heb een testfiletjes gemaakt, met daarin momenteel 6 sheets.
Achter "Blad1" staat de code om bij een wijziging in kolom "B", Sheet "1" te kopiëren en bij te voegen.
Op "Blad6" staan koppelingen naar deze sheets. Dus in rij 2 naar '1', rij 3 naar '2', rij 4 naar '3', enz....
In mijn oude file staan zo ongeveer 90 rijen met steeds dezelfde formules, telkens verwijzend naar de bewuste sheets, maar dan moest ik natuurlijk eerst al die sheets aanmaken.
Met de code achter "Blad1", moet ik nu dus niet al die sheets meer op voorhand allemaal aanmaken, maar kan ik dus ook niet de formules op "Blad6" op voorhand zetten, want uiteraard worden dan de sheets die nog niet bestaan niet gevonden.
Nu is het mijn vraag of nadat de volgende sheet is ingevoegd, op "blad6" de formules automatisch kunnen gekopieerd worden naar de volgende rij, waarbij dan de verwijzing naar de sheet ook wordt aangepast.
Ik heb voor het kopiëren, plakken en wijzigen van de verwijzing een macro opgenomen, maar weet niet hoe ik die eventueel mee kan inpassen in de bestaande code achter "Blad1".
Hopelijk is mijn uitleg duidelijk en als bijlage ook het testfiletje.

 

[HSV]

Als het altijd "C1:C6" is.

Sub hsv()
Dim sh As Worksheet
  For Each sh In ThisWorkbook.Worksheets
   If Not WorksheetFunction.Or(sh.Name = "Blad1", sh.Name = "Blad6") Then
  Sheets("Blad6").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6) = Application.Transpose(sh.Range("C1:C6").Value)
   End If
 Next sh
End Sub

 

[Niels28]

zoiets?

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target = "" Or Target.Cells.Count > 1 Then Exit Sub
        If Target.Column = (2) Then
            Sheets("1").Copy , Sheets(Sheets.Count)
            With ActiveSheet
                .Name = Target.Offset(, -1).Value
            End With
                    Lrow = Sheets("blad6").Cells(Rows.Count, "A").End(xlUp).Row + 1
        For i = 1 To 6
        Sheets("blad6").Cells(Lrow, i) = "=" & chr39 & Target.Offset(, -1).Value & chr39 & "!c" & i
        Next
        End If
  
End Sub

 

[bowlingman]

Bedankt voor de snelle reactie.

@ Harry, bij Uw code worden de rijen die reeds ingevuld zijn gekopieerd en vervolgens daaronder aansluitend geplakt, maar niet de formules wel de waarden die er reeds stonden.

@Niels, Uw code werkt perfect en doet exact wat ik bedoel.

Grtjs.
Armand

 

[Niels28]

Misschien moet je nog een controle toevoegen voor het geval het tabblad al bestaat?
Anders krijg je een foutmelding als je een dubbele invult.

Niels

 

[bowlingman]

Hallo Niels,
Bedankt voor de mededeling.
Maar dit is eigenlijk niet nodig, vermits de namen van de leden met frm worden ingevuld en wanneer je een iDnr in de cbo kiest, komt in de txtNaam de naam van de speler te staan die bij deze iD hoort en kan je dus zien of het bewuste iD nog vrij is.
Zodoende kan je dus elk nr maar één keer gebruiken.

Grtjs.
Armand

 

[bowlingman]

Hallo Niels,
In de testfile werkte de code perfect, dus ik dacht ik zet deze code in mijn originele file en pas aan waar nodig.
En dit is het resultaat

 Private Sub Worksheet_Change(ByVal Target As Range)
    If Target = "" Or Target.Cells.Count > 1 Then Exit Sub
            If Target.Column = (6) Then
                Sheets("500").Copy , Sheets(Sheets.Count - 2)
                With ActiveSheet
                    .Name = Target.Offset(, -1).Value
                    .Range("K2") = Target.Offset(, -1).Value
                End With
                    Lrow = Sheets("Handicaps").Cells(Rows.Count, "B").End(xlUp).Row + 1
                For i = 1 To 30
                Sheets("Handicaps").Cells(Lrow, i + 1) = "=" & chr39 & Target.Offset(, -1).Value & chr39 & "!$m$" & i
                Next
            End If
        If Not Intersect(Target, Range("A29")) Is Nothing Then
        Sheets("500").Rows("40:45").EntireRow.Hidden = False
        Select Case Target.Value
        Case 28
        Sheets("500").Rows("44:45").EntireRow.Hidden = True
        Case 25
        Sheets("500").Rows("41:45").EntireRow.Hidden = True
        Case 24
        Sheets("500").Rows("40:45").EntireRow.Hidden = True
        End Select
        End If
End Sub

Nu worden de gegevens correct weggeschreven en gekopieerd enz...
Maar de handicaps staan in de cellen "M15:M44" en wanneer deze dan gekopieerd worden, worden deze gewijzigd in "M1:M30".
Ik dacht om dit op te lossen verander ik gewoon "1 to 30" in "15 to 44", maar dat werkte dus niet.
Nu werd alles wel niet veranderd maar dan wel 15 kolom verder opgeschoven alsook werd de eerste geplakte rij gewoon overschreven.
Ik weet in de testfile, had ik het gewoon gedaan van rij 1 tot 6, maar ik dacht dat ik dit dan gewoon kon aanpassen naar 15 to 44.

Grtjs.
Armand

 

[bowlingman]

Oeps Niels,

Ben iets te snel geweest.
Heb het gevonden.
Ik heb de code

For i = 1 To 30
         Sheets("Handicaps").Cells(Lrow, i + 1) = "=" & chr39 & Target.Offset(, -1).Value & chr39 & "!$m$" & i
         Next

als volgt gewijzigd

For i = 1 To 30
         Sheets("Handicaps").Cells(Lrow, i + 1) = "=" & chr39 & Target.Offset(, -1).Value & chr39 & "!$m$" & i [COLOR="#FF0000"]+ 14[/COLOR]
         Next

Maar heb toch nog een vraagje.
Kan ik de Option Button op mijn frm selecteren gewoon met enter of moet ik die steeds gewoon aanklikken.


Grtjs.
Armand

 

[Niels28]

Met enter kun je hem niet aanvinken met spatie wel.
Het selecteren kun ja aangeven bij de tabvolgorde

Niels

 

[bowlingman]

Hallo Niels,

Bedankt voor je reactie.
Wist niet dat dit ging met de spatiebalk, het selecteren gebeurde al met de tabvolgorde

Grtjs.
Armand