Navigation

Dim Fra As Worksheet
Set Fra = Ark1

Dim Til As Worksheet
Set Til = Ark2
Sub kopierTilAndetArk()
Dim rngCopy As Range
Dim rngPaste As Range

'Hvilket område der skal kopieres
'I stedet for Ark1, og Ark2, kan du bruge Worksheets ("Data") eller Worksheets ("Arkiv"). Jeg anbefaler dig dig, at bruge kodenavne til arkene.
Set rngCopy = Ark1.Range("A2:B9")

'Hvilket område der skal indsættes i
Set rngPaste = Ark2.Range("A2")

'Kopirer data - Du kan også lave cut i stedet.
rngCopy.Copy

'Indsætter data.
rngPaste.Insert
End Sub

Sub kopirerTilAndetArkOgSletFraGammelArk()
Dim rngAllDates As Range
Dim rngDate As Range
Dim nArchiveLastRow As Integer
Dim strRowsToDelete As String

'Hvor er data´erne der skal tjekkes.
Set rngAllDates = Ark1.Range("A2:A8")

'Går gennem alle datoerne
nArchiveLastRow = 1
For Each rngDate In rngAllDates

    'Hvis datoen er "mindre end" (ældre) end dags dato
    If rngDate.Value < Now Then
        Debug.Print "Dato ældre end dags dato - flyttes til arkiv"

        'Overfører værdien
        Ark2.Cells(nArchiveLastRow, 1) = rngDate.Value
        Ark2.Cells(nArchiveLastRow, 2) = rngDate.Offset(0, 1).Value

        'Hvis der er mere end én række og tekststrengen er længere end 0 tegn
        If rngAllDates.Count > 1 And Len(strRowsToDelete) > 0 Then
            strRowsToDelete = rngDate.Row & ":" & rngDate.Row & "," & strRowsToDelete
        Else
            strRowsToDelete = rngDate.Row & ":" & rngDate.Row
        End If

        'Går til næste række
        nArchiveLastRow = nArchiveLastRow + 1
    End If
Next rngDate

'Sletter rækkerne
Ark1.Range(strRowsToDelete).EntireRow.Delete

End Sub

Navigation

Kopiere rækker i nyt ark