Avatar billede jan Novice
12. januar 2008 - 00:31 Der er 17 kommentarer og
1 løsning

kopi af celler - endnu engang

I forlængelse af mit tidligere spørgsmål http://www.eksperten.dk/spm/812812 har jeg oprettet følgende kode for at kopire fra et stort ark over i en række efterfølgende ark.
Problemet er at det kopirer alt, det vil sige både formler og indhold. Hvis jeg kun ønsker at indholdet skal kopires over, hvordan gør jeg så.

koden ser ud som følger

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.Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A")
End If
End If
Next
Set sh1 = Sheets("4 ugers turnus")
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.Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A")
End If
osv.
Avatar billede excelent Ekspert
12. januar 2008 - 08:25 #1
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
Avatar billede jan Novice
12. januar 2008 - 21:18 #2
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
Avatar billede excelent Ekspert
13. januar 2008 - 08:16 #3
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
Avatar billede jan Novice
13. januar 2008 - 11:00 #4
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
Avatar billede excelent Ekspert
13. januar 2008 - 11:03 #5
øjeblik tester lige
Avatar billede excelent Ekspert
13. januar 2008 - 11:16 #6
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
Avatar billede excelent Ekspert
13. januar 2008 - 11:27 #7
er tilbage om en time
Avatar billede jan Novice
13. januar 2008 - 11:35 #8
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?
Avatar billede excelent Ekspert
13. januar 2008 - 12:36 #9
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.
Avatar billede jan Novice
13. januar 2008 - 13:05 #10
hvordan sender jeg filen til dig?
Avatar billede excelent Ekspert
13. januar 2008 - 13:11 #11
højreklik på fil-ikon
vælg Send til > Postmodtager
pm@madsen.tdcadsl.dk
Avatar billede jan Novice
13. januar 2008 - 15:00 #12
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
Avatar billede excelent Ekspert
13. januar 2008 - 16:54 #13
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
Avatar billede excelent Ekspert
14. januar 2008 - 09:29 #14
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
Avatar billede excelent Ekspert
14. januar 2008 - 19:55 #15
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.)
Avatar billede jan Novice
14. januar 2008 - 21:03 #16
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
Avatar billede excelent Ekspert
14. januar 2008 - 21:52 #17
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.
Avatar billede jan Novice
14. januar 2008 - 23:37 #18
det er perfekt
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester