Kopieren van regels naar ander tabblad.

[gaggie]

Ik heb 2 tabbladen:

Tabblad: database hier staan allerlei resultaten in. Van kolom A t.m M
Tabblad: historie hier wil ik alle regels uit database waarbij in de cel van kolom M (staat jaartal vernoemd) < huidige jaar -4 komen.
Het kopieren moet na de laatste regel van historie gedaan worden.
Historie wordt dus steeds groter.
De regels moeten na de kopieslag verwijderd worden uit database

Heeft iemand misschien een vba oplossing.

Mvg.

Gaggie

 

[edmoor]

Plaats even een voorbeeld document zodat men zelf geen data voor het tabblad Database hoeft te verzinnen. Laat daarin tevens zien wat de layout van het tabblad Historie moet zijn.

 

[snb]

En vooral: neem eens een macro op.

 

[gaggie]

Hierbij een voorbeeld bestand.

Tabblad database daar staan de resultaten met in kolom M een jaartal

Nu wil ik alle regels waarbij het jaartal < huidigjaar-4 naar tabblad historie, zodat tabblad historie steeds groter wordt met oud data. Die wil ik later misschien nog inzien.Bekijk bijlage databaseenhistorie.xlsm

 

[Niels28]

En vooral: neem eens een macro op.

en als je de macro opneemt terwijl je een filter op je gegeven zet die filtert op datum
daarna kopieert, plakt en verwijderd ben je een heel eind.

Niels

 

[gaggie]

Met filteren daar kom ik niet uit, wel geprobeert.

Heb ondertussen een stukje code gevonden die de juiste regels kopieert naar tabblad historie.
Alleen blijven de regels die gekopieerd zijn uit tabblad Database naar historie bestaan in tabblad Database die regels wil ik graag verwijderd hebben.
Zou iemand even naar de code willen kijken en aangeven wat ik zou moeten aanpassen.
Bij voorbaat dank.

Sub Test()
Dim i As Long
Dim lr1 As Long, lr2 As Long
Dim Delta As String
Dim wks1 As Worksheet, wks2 As Worksheet
Dim iyear As Integer

iyear = Year(Now) - 4

Set wks1 = Worksheets("Database")
Set wks2 = Worksheets("historie")
lr1 = wks1.Cells(Rows.Count, "M").End(xlUp).Row
For i = 2 To lr1
    Delta = wks1.Cells(i, "M").Value
    
    If Delta <= iyear Then
        lr2 = wks2.Cells(Rows.Count, "A").End(xlUp).Row + 1
        wks1.Cells(i, "N").EntireRow.Copy Destination:=wks2.Cells(lr2, "A")
    End If
Next i


End Sub

Mvg.

Gaggie

 

[gaggie]

heb ondertussen een oplosing gevonden, ik zet de code hier neer, misschien heeft iemand er wat aan.

Sub regels()
Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long
Dim iyear As Integer
Dim ws As Worksheet
Dim wo As Worksheet


iyear = Year(Now) - 4

Application.ScreenUpdating = False

Set ws = Sheets("Database")
Set wo = Sheets("historie")

lastrow = ws.UsedRange.Rows.Count
lastrow2 = wo.UsedRange.Rows.Count



If lastrow2 = 1 Then lastrow2 = 0
    For r = lastrow To 2 Step -1
        If ws.Range("M" & r).Value <= iyear Then
            ws.Rows(r).Cut Destination:=wo.Range("A" & lastrow2 + 1)
            lastrow2 = lastrow2 + 1
            Else:
        End If
    Next r


Application.ScreenUpdating = True

End Sub

Mvg Gaggie