kopi af celler

Kode anbringes i ark1:

Const aktuelleMd = 1                                'Aktuelle måned (JAN)
Dim antalKol, ark2Ræk
Sub kopiAfCeller()
    Application.ScreenUpdating = False
   
Rem Række påArk2
    ark2Ræk = 1
   
Rem Beregn antalkolonner
    antalKol = ActiveCell.SpecialCells(xlLastCell).Column
   
        For ræk = 1 To 65000
            ActiveWorkbook.Sheets("Ark1").Activate
            If Cells(ræk, 1) = "" Then
                Application.ScreenUpdating = True
                MsgBox ("Kopiering afsluttet")
                Exit Sub
            End If
           
Rem måned = ønskede - kopier til ark2
            If Month(Cells(ræk, 1)) = aktuelleMd Then
                Range(Cells(ræk, 1), Cells(ræk, antalKol)).Select
                Selection.Copy
               
                ActiveWorkbook.Sheets("Ark2").Select
                Cells(ark2Ræk, 1).Select
                Selection.PasteSpecial (xlPasteAll)
               
                Application.CutCopyMode = False
                ark2Ræk = ark2Ræk + 1
            End If
        Next ræk
End Sub

Hej supertekst. Du må hjælpe mig, hvad menes med "kode anbringes i ark1"

højreklik på arket > vis programkode > indsæt koden og luk vinduet igen

nu kan du så ved at trykke alt+F8 afspille ovennævte

@supertekst genial kode forresten

OK - jeg har nu lagt programkoden ind men kan ikke få det til at virke.
lader jeg datorækken starte i A1 modtager jeg en fejlmeddelse der hedder 400 samtidig med at a1 og b1 ( den med indhold i række 1) er markeret som ved kopiring.
Lader jeg datolisten begynde et tilfældigt sted f.eks A10 modtager jeg meddelsen om at kopiringen er fuldført med intet er kopiret over på ark2

indsæt i et alm. modul

Sub xFlyt()
m = 1 ' januar måned
Set sh1 = Sheets("Ark1")
Set sh2 = Sheets("Ark2")
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If Month(sh1.Cells(t, "A").Value) = m Then
sh1.Range("A" & t & ":AA" & t).Copy sh2.Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A")
End If
End If
Next
End Sub

Det virker - dejligt.
Hvis nu jeg vil fortsætte programkode for februar / ark3 hvor skal jeg så lægge fortsættelsen.
og hvis jeg vil lade teksten på ark2 begynde på linie 10, er det så denne komando 1000, "A").End(xlUp).Row + 1, "A")jeg ændre til 1000, "A").End(xlUp).Row + 10, "A")
Jeg må gi mine point til excelent

Sub xFlyt()
m = 1 ' januar måned
Set sh1 = Sheets("Ark1")' Værdier kopieres fra Ark1 - ret til aktuel
Set sh2 = Sheets("Ark2")' værdier kopieres til Ark2 - ret til aktuel
sh1.Range("A1:AA1").Copy sh2.Range("A10") ' indsætter en overskrift i række 10, resten indsættes derunder
For t = 1 To sh1.Cells(1000, "A").End(xlUp).Row
If IsDate(sh1.Cells(t, "A")) = True Then
If Month(sh1.Cells(t, "A").Value) = m Then
sh1.Range("A" & t & ":AA" & t).Copy sh2.Cells(sh2.Cells(1000, "A").End(xlUp).Row + 1, "A")
End If
End If
Next
End Sub

Hvis du ikke har en overskrift, eller ønsker en sådan kopieret over, kan vi indsætte en midlertidig værdi i række A9 el A10
Dette er for at kopierede værdier indsættes fra række 9 el 10