CIO Tech Eksperten IT-JOB IT-Kurser Events Podcast Søg
Cookie ikon
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

Flere spørgsmål fra Excel kategorien

Titel Indlæg Oprettet Seneste aktivitet
Formler der blev væk Af Klaus W i Excel 5 I går 19:32 I dag 20:28
Få excel til at indsætte værdi i månedsfelter ud fra start og stop dato Af CBH i Excel 6 08/05/202413:16 13/05/202414:31
Dato opslag udfordring igen igen Af Klaus W i Excel 6 08/05/202410:15 08/05/202416:07
Sumfunktion ud fra dato Af scholes i Excel 3 08/05/202408:34 08/05/202413:29
Vise flere ark fra samme workbook Af Nanarsi i Excel 3 07/05/202410:33 09/05/202412:56
Se alle spørgsmål i kategorien Opret spørgsmål

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.

Opret Log ind

Du kan også logge ind via nedenstående tjenester



Alle kategorier på Eksperten
Seneste spørgsmål Seneste aktivitet
I dag 15:30 signalforstærker til trådløs rutrer tænkes brugt til pc næt pc -og MÅSKE TV 4 m borte eller begge Af Novice-1 i Routere & Switches
I dag 11:43 Hvilket styresystem på en gammel Pc ??? Af Jan Post i Andre styresystemer
I dag 07:44 Virus advarsler - falske Af jdann i Backup- & Antivirus
I går 19:32 Formler der blev væk Af Klaus W i Excel
I går 15:22 Hent array key Af nemlig i PHP
White papers
Flere white papers »


Premium
Teaser billede
Her er de nye medlemmer af Statens It-råd: Skal vurdere it-projekter på over 15 millioner kroner
Læs mere »
Antallet af anmeldelser af ulovligt indhold på beskedtjenester stiger: Regeringen skubber ansvaret videre til EU og Belgien
Efter masser af kritik af store prisstigninger: VMware åbner for gratis licenser - ændrer i licens-strukturen
Seks store selskaber med på årets image-liste for første gang: Kæmper alle med lav kendskabsgrad
Se alle »
Computerworld
Teaser billede
Nyopdaget sårbarhed rammer næsten alle VPN'er: Gør dem usikre og nærmest ubrugelige
Læs mere »
Om under en uge går det løs: Pc’en bliver aldrig den samme igen
VPN-test fra virkeligheden: To tjenester som glimrer på hver deres måde
Test: Samsungs nyeste laptop er noget af det tætteste du kommer på en Windows-Macbook
Se alle »
CIO
Teaser billede
Nu begynder den største GDPR-retssag mod dansk myndighed nogensinde: Står over for million-bøde
Læs mere »
Lukker it-systemerne ned i to uger på grund af implementering: Den bedste måde at sikre, at ingen data går tabt
Sådan har Coop sagt farvel til mainframen - sparer et to-cifret millionbeløb årligt på licenser
Hundredevis af selskaber klager over Microsofts licens-policy: Vi er låst fast og bundet
Se alle »
Job & Karriere
Teaser billede
Her er Danmarks fem bedste CIO’er lige nu: Se de fem nominerede til prisen som Årets CIO 2024
Læs mere »
Medarbejderne fik udleveret badetøfler ved indflytningen: Kom med inden for i IBM Danmarks nye topmoderne hovedkontor
Så meget tjener dine kollegaer: Her er alle data fra Computerworlds store it-lønstatistik for 2024
Får du den løn, du fortjener? Få overblikket over hvor meget dine kolleger tjener hver måned
Se alle »
White paper
Teaser billede
Få mere ud af din cloudinfrastruktur og gør op med de konstant stigende omkostninger
Læs mere »
MDR: Transparent sikkerhed og overvågning i realtid
Det behøver ikke at gøre ondt: Sådan gør du livet lettere for kunder med multicloud
Sådan høster du forretningsfordelene ved Internet of Things
Se alle »

Events
Flere events »
White papers
Flere white papers »
IT-Kurser
Se alle vores it-kurser »