kopi af celler - endnu engang

Set sh1 = Sheets("4 ugers turnus")
Set sh2 = Sheets(sh1.Range("x14").Value)
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If sh1.Cells(t, "A") >= sh1.Range("t14") And sh1.Cells(t, "A") <= sh1.Range("v14") Then
' ændring/tilføjelser umiddelbart efter "Copy"
sh1.Range("A" & t & ":AA" & t).Copy
sh2.Select
Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues
sh1.Select
End If
End If

Jeg modtager følgende fejlmeddelse

Metoden Copy for klassen Range mislykkedes

kode er

Set sh1 = Sheets("4 ugers turnus")
Set sh2 = Sheets(sh1.Range("x16").Value)
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If sh1.Cells(t, "A") >= sh1.Range("t16") And sh1.Cells(t, "A") <= sh1.Range("v16") Then
sh1.Range("A" & t & ":AA" & t).Copy sh2.Select
Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues
sh1.Select
End If

Linien det er galt med er :

sh1.Range("A" & t & ":AA" & t).Copy sh2.Select

denne linje skal deles i 2

sh1.Range("A" & t & ":AA" & t).Copy sh2.Select
til
sh1.Range("A" & t & ":AA" & t).Copy
sh2.Select

jeg har delt linie som du skriver, men nu rykker problemet en linie ned til

Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select

øjeblik tester lige

ok prøv denne: obs.
denne stump er en modifiseret udgave af den første kodestump
i dit første indlæg, den anden kode skal ændres ligeså

Set sh1 = Sheets("4 ugers turnus")
Set sh2 = Sheets(sh1.Range("x14").Value)
Application.ScreenUpdating = False
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If sh1.Cells(t, "A") >= sh1.Range("t14") And sh1.Cells(t, "A") <= sh1.Range("v14") Then
sh1.Range("A" & t & ":AA" & t).Copy
sh2.Select
Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sh1.Select
Cells(2, 12).Select
End If
End If
Next
Application.ScreenUpdating = True

er tilbage om en time

Hmmm, nu kopirer den intet over. Jeg har forstået det rigtigt ved simpelhen at smide den gamle ud og erstatte den af den nye?

hmm muligvis :-)
Jeg kan se du har udvidet koden som anvendtes i den oprindelige fil jeg oploadede.
Så prøv lige at indsætte hele kode her, eller endnu bedre, send filen til mig.

hvordan sender jeg filen til dig?

højreklik på fil-ikon
vælg Send til > Postmodtager
pm@madsen.tdcadsl.dk

Jeg kan desværre ikke sende hele filen til dig. Den fylder 7MB og outlook vil ikke opdele filenj i míndre stykker så den kan sendes. Ærgeligt, så her får du den stump jeg pt har lagt ind

Private Sub CommandButton5_Click()
Set sh1 = Sheets("4 ugers turnus")
Set sh2 = Sheets(sh1.Range("x14").Value)
Application.ScreenUpdating = False
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If sh1.Cells(t, "A") >= sh1.Range("t14") And sh1.Cells(t, "A") <= sh1.Range("v14") Then
sh1.Range("A" & t & ":AA" & t).Copy
sh2.Select
Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sh1.Select
Cells(2, 12).Select
End If
End If
Next
Application.ScreenUpdating = True
Set sh1 = Sheets("4 ugers turnus")
Set sh2 = Sheets(sh1.Range("x15").Value)
Application.ScreenUpdating = False
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If sh1.Cells(t, "A") >= sh1.Range("t15") And sh1.Cells(t, "A") <= sh1.Range("v15") Then
sh1.Range("A" & t & ":AA" & t).Copy
sh2.Select
Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sh1.Select
Cells(2, 12).Select
End If
End If
Next
Application.ScreenUpdating = True
Set sh1 = Sheets("4 ugers turnus")
Set sh2 = Sheets(sh1.Range("x16").Value)
Application.ScreenUpdating = False
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If sh1.Cells(t, "A") >= sh1.Range("t16") And sh1.Cells(t, "A") <= sh1.Range("v16") Then
sh1.Range("A" & t & ":AA" & t).Copy
sh2.Select
Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sh1.Select
Cells(2, 12).Select
End If
End If
Next
Application.ScreenUpdating = True
End Sub

ok det prøv denne:

Private Sub CommandButton5_Click()

Application.ScreenUpdating = False
Set sh1 = Sheets("4 ugers turnus")

Set sh2 = Sheets(sh1.Range("x14").Value)
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If sh1.Cells(t, "A") >= sh1.Range("t14") And sh1.Cells(t, "A") <= sh1.Range("v14") Then
sh1.Range("A" & t & ":AA" & t).Copy
sh2.Select
sh2.Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sh2.Cells(1, 1).Select
End If
End If
Next

Set sh2 = Sheets(sh1.Range("x15").Value)
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If sh1.Cells(t, "A") >= sh1.Range("t15") And sh1.Cells(t, "A") <= sh1.Range("v15") Then
sh1.Range("A" & t & ":AA" & t).Copy
sh2.Select
sh2.Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sh2.Cells(1, 1).Select
End If
End If
Next

Set sh2 = Sheets(sh1.Range("x16").Value)
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If sh1.Cells(t, "A") >= sh1.Range("t16") And sh1.Cells(t, "A") <= sh1.Range("v16") Then
sh1.Range("A" & t & ":AA" & t).Copy
sh2.Select
sh2.Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sh2.Cells(1, 1).Select
sh1.Select
End If
End If
Next
Application.ScreenUpdating = True

End Sub

Er ikke sikker på du fik min mail, men prøv ret følgende linie
If sh1.Cells(t, "A") >= sh1.Range("t14") And sh1.Cells(t, "A") <= sh1.Range("v14") Then
til
If sh1.Cells(t, "A") >= sh1.Range("t17") And sh1.Cells(t, "A") <= sh1.Range("v17") Then
så vil den fange de datoer du p.t. har i kolonne A

Men der skal tilføjes mere kode så alle perioder er dækket
lige som du har i Private Sub CommandButton2_Click() - vil jeg tro

Det ser ikke ud til der er hul igennem endnu
men ovenstående kode virker ok, har testet.
Dog dækker den kun perioden 15-januar til 14april
du skal derfor udvide koden lige som i Private Sub CommandButton2_Click() (ovenstående dækker for 3 mdr.)

det virker med den kode som indeholder
Application.ScreenUpdating = False
Set sh1 = Sheets("4 ugers turnus")

Set sh2 = Sheets(sh1.Range("x14").Value)
- og jeg samtidig husker at året i startdato (a40) og året i turnusperioden (m34) skal være det samme! Sorry

Eneste undtagelse er følgende hvor den også kopirer formlen

i A4o indskriver jeg startdato
i b40 har jeg et hvis-argument om at hvis datoen ikke = mandag så skal man....
i A43 = A40 . Denne celle er den første dato i kalenderrækken.

Når a43 kopires over i arkJan, arkFeb m.m. bliver denne startdato altid kopiret som teksten i a40+b40. Er det ikke underligt?

Og så glemte jeg lige det med point og tak for hjælpen

velbekom

Prøv lige at ændre denne :
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
til
For t = 43 To sh1.Cells(1000, "A").End(xlUp).Row
så testes kun fra række 43 og ned
Det skal ændres i alle 3 tilfælde
samt indføjes i de resterende du tilføjer.

det er perfekt