Flette celler i rækker udfra uge nr.

Sub Merge1()
Dim rng As Range
Dim rng2 As Range
Set rng = Sheets("Ark1").Range("B35:BB35") '** ret evt.Arknavn her

For t = 1 To 12
For Each c In rng
  If c = t Then
      If rng2 Is Nothing Then
        Set rng2 = c
            Else
        Set rng2 = Application.Union(rng2, c)
      End If
  End If
Next
rng2.Select
Application.DisplayAlerts = False

    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
   
Application.DisplayAlerts = True

Set rng2 = Nothing
Next
End Sub

Hej Excelent

Mange tak fordi at du gider at prøve og finde en løsning.

Jeg har sat din kode ind i arket. Skal ark navn være det navn jeg har givet arket i XL eller det ark navn som det har i VB.

Jeg har prøvet med det navn som XL viser giver den(ATP). Den kommer med flg fejl:
Object varible or with block varible not set

men nu kommer jeg helt i tvivl om hvilket format du vil have det i tekst el. tal?

Nå ja gik ud fra det var tal 1 til 12
er det datoer som er formateret til mmm el lign.

Det er navnet i XL du skal bruge

Hej

Ja, det er datoer, med mmmm formatet.

har også prøvet at lave dem om til tekst, men intet hjælper

prøv lige denne

Sub Merge1()
Dim rng As Range
Dim rng2 As Range
Set rng = Sheets("ATP").Range("B35:BB35")

For t = 1 To 12

For Each c In rng
  If Month(c) = t Then
      If rng2 Is Nothing Then
        Set rng2 = c
            Else
        Set rng2 = Application.Union(rng2, c)
      End If
  End If
Next
rng2.Select
Application.DisplayAlerts = False

    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
   
Application.DisplayAlerts = True

Set rng2 = Nothing
Next
End Sub

Hvis ikke du har tal op til 12 (december), så ret i koden til sidste måned i linie 5

Hej

Den springer december over, er det noget med mine uger at gøre?

hej

tror det er noget andet, jeg har lavet sådan at jeg angiver en start dato for min sæson. Når jeg skifter rundt med den, er det lidt forskellige måneder den springer over, den laver bare en mdr. dobbelt så lang.

ja eller antal, eller placering
jeg tror du skal skrive hvad du har hvorhenne
evt. også formlen i første celle, hvis dato er beregnet

ellers send filen, eller et eks.

har sendt en fil til dig

VH Dan

ok modtaget
Har lige skiftet til fibernet, så bøvler noget med mail opsætning
skal nok kikke på det senere

ok prøv :

Sub Merge2()
Dim rng As Range
Dim rng2 As Range
Application.ScreenUpdating = False
Set rng = Sheets("ATP").Range("B35:BB35")

For Each d In rng
For Each c In rng
  If Month(c) = Month(d) Then
      If rng2 Is Nothing Then
        Set rng2 = c
            Else
        Set rng2 = Application.Union(rng2, c)
      End If
  End If
Next
rng2.Offset(1, 0).Select

Application.DisplayAlerts = False

    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
   
Application.DisplayAlerts = True

Set rng2 = Nothing
Next
Application.ScreenUpdating = True
End Sub

Hej excelent

Denne virker.

dog vil jeg høre om man kan få den til at starte med at nulstille rækken først, dvs. ophæve alle flettninger. Derved kan jeg bare køre makroen hvis startdatoen bliver ændret.

lige et tillægsspørgsmål, nu har du jo set mit ark.
på ATP,en, kan man få indtastnings områderne til at følge dato rækken, dvs. hvis start dato bliver ændret, flytter mine indtastninger med til enten højre eller venstre.

VH Dan

Udskift din kode med denne, så kører koden når du skifter dato

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("R29")) Is Nothing Then Exit Sub
Dim rng As Range
Dim rng2 As Range
Application.ScreenUpdating = False
Set rng = Sheets("ATP").Range("B35:BB35")
Sheets("ATP").Range("B36:BB36").UnMerge

For Each d In rng
For Each c In rng
  If Month(c) = Month(d) Then
      If rng2 Is Nothing Then
        Set rng2 = c
            Else
        Set rng2 = Application.Union(rng2, c)
      End If
  End If
Next
rng2.Offset(1, 0).Select

Application.DisplayAlerts = False

    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
   
Application.DisplayAlerts = True
Selection = Selection.Offset(-1, 0).Value
Set rng2 = Nothing
Next
Application.ScreenUpdating = True
End Sub

Tillægsspørgsmål forstår jeg ikke helt
hvad er "Indtastnings områderne" ?

Hej excelent

den sidste kode sætter ikke kant på efter fletning. jeg har prøvet at rode lidt med det selv, fatter dog ikke noget, kan ikke få det til at virke.

er det korekt at jeg skal fjerne de to første linjer i den sidste kode, også lade de første linjer af den kode som hedder merge2() blive?

mht indtastningsomr. som er dette de hvide omr. i ATP, under uge nr.  her er det mening at sætter et bogstav alt efter hvilken periode denne uge skal være mærket som. De to nederste omr. vil blive brugt til at sætte tal ind, der viser træningen i de enkelte zoner.

VH Dan

Slet alt kode jeg har lavet
og så indsæt den sidste i arkets kodemodul - (kodemodulet finder du ved at højreklikke på arkfane og vælg "Vis programkode")

Tillægsspørgsmål fatter jeg ikke

Hej Excelent

er det mening at den kører automatisk?

Kan se at du har sat den til at kigge i r29. denne celle er nu kun en formel, skal jeg flytte den over til den celle som der bliver tastet i, dette er på et andet ark.

du skal rette R29 i koden til den celle du taster dato i

JEg kan stadig ikke få nakroen til at gå igang. Det felt jeg taster i er på et andet ark. I koden skriver ændrer jeg
(Target, Range("R29")) til
(Target, Sheets("Pers. opl").Range("H2")

er dette korrekt

JEg kan sagtens leve med at skal aktivere en makro via en genvejs tast, hvis det kan hjælpe os.

ok nej indtastnings celle skal være i samme ark som koden
men så smider du koden ind i et almindeligt Modul

I projektmappen taster du ALT+F11
I menuen Insert, vælger du Module
Indsæt koden der
Husk slet koden i Arkmodulet

Sub Merge3()
Dim rng As Range
Dim rng2 As Range
Application.ScreenUpdating = False
Set rng = Sheets("ATP").Range("B35:BB35")
Sheets("ATP").Range("B36:BB36").UnMerge

For Each d In rng
For Each c In rng
  If Month(c) = Month(d) Then
      If rng2 Is Nothing Then
        Set rng2 = c
            Else
        Set rng2 = Application.Union(rng2, c)
      End If
  End If
Next
rng2.Offset(1, 0).Select

Application.DisplayAlerts = False

    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
   
Application.DisplayAlerts = True
Selection = Selection.Offset(-1, 0).Value
Set rng2 = Nothing
Next
Application.ScreenUpdating = True
End Sub

OBS hvis du starter koden fra et andet ark, så indsæt lige

Sheets("ATP").Select

i starten af koden (som linie 4)
så arket bliver aktiveret

hej excelent.

Den er næsten i hus. Den fletter helt rigtigt. Den slutter dog ikke af med at sætte en kant linie på, bare i højre side er fint, så vil de være adskilt. Kan du hjæjpe med det.

Af en eller anden grund får jeg ikke mail når du kommenterer her i tråden, det er så årsagen til at der går lidt tid imellem

Men ja jeg er opmærksom på det med rammerne så prøv denne:
husk slet den gamle kode!

Sub Merge4()
Dim rng As Range
Dim rng2 As Range
Application.ScreenUpdating = False
Sheets("ATP").Select
Sheets("ATP").Range("B36:BB36").UnMerge
Set rng = Sheets("ATP").Range("B35:BB35")

For Each d In rng
For Each c In rng
  If Month(c) = Month(d) Then
      If rng2 Is Nothing Then
        Set rng2 = c
            Else
        Set rng2 = Application.Union(rng2, c)
      End If
  End If
Next
rng2.Offset(1, 0).Select

Application.DisplayAlerts = False

    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
   
Application.DisplayAlerts = True
Selection = Selection.Offset(-1, 0).Value
Set rng2 = Nothing
Next
ramme
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Sub ramme()

    Range("B36:BB36").Select

    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

End Sub

Hej Excelent.

Dette er helt perfekt.

Jeg har indsat to linjer til at låse arket op samt beskytte det igen, også fra dig.

Takker mange gange.

smid et svar så du kan få point

VH Dan

ok velbekom