Copy Paste Makro

Du kan kopiere de valgte celler i et filter med

Sub CopyFilter()
    Dim r, r2 As range

    On Error Resume Next
        With ActiveSheet.AutoFilter.range
            Set r2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        End With
    On Error GoTo 0

    If r2 Is Nothing Then
        MsgBox "No data shown by filter"
    Else
        Set r = ActiveSheet.AutoFilter.range
        r.Offset(1, 0).Resize(r.Rows.Count - 1).Copy Destination:=r.Offset(r.Rows.Count, 0).Cells(1, 1)
    End If
End Sub

Du mangler så at udvide filteret til også at omfatte de nye data (hvis ønsket) og kopiere de nye data ind. Er det de samme data for hver alle rækkerne og hvor kommer de data fra?

Data benyttes til prissammenligning i på et givent produkt.

Data består af et produkt med 6 forskellige priser afhængig af periode for et år. Alle produkter er altså repræsenteret 6 gange, med 6 priser for et givent år.

Disse 6 rækker skal kopieres ned i nyt område, hvorefter oplysninger om år ændres til nyt år, alle priser nulstilles og et statusfelt opdateres med oplysninger såsom "Videreført til nyt år"

Bruger skal herefter indtaste de nye priser for det pågældende produkt i de nye 6 rækker således at der efterfølgende kan laves en prissammenligning.

Giver det mening ?

Jo da:

Sub CopyFilter()
    Dim r, r2, d As range
    Dim n As Long
    Dim cYear, cStatus, cPrice
    Dim tStatus As String
   
    cYear = 1
    cStatus = 3
    cPrice = 6
    tStatus = "Videført til nyt år"
   
    On Error Resume Next
        With ActiveSheet.AutoFilter.range
            Set r2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            n = .Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
        End With
    On Error GoTo 0

    If r2 Is Nothing Then
        MsgBox "No data shown by filter"
    Else
        MsgBox n
        Set r = ActiveSheet.AutoFilter.range
        Set d = r.Offset(r.Rows.Count, 0).Cells(1, 1)
        r.Offset(1, 0).Resize(r.Rows.Count - 1).Copy Destination:=d
        d.Offset(0, cYear).Resize(n).Value = year(Date)
        d.Offset(0, cStatus).Resize(n).Value = tStatus
        d.Offset(0, cPrice).Resize(n).Clear
    End If
End Sub

Denne her antager, at år, status og pris står i hhv kolonnerne 1, 3 og 6 i dit filter-område. Den sætter året til det aktuelle år, Status til den angivne tekst og sletter prisen.

Duer det?

Ups - slet lige "Msgbox n" linien

Alt bortset fra

  If r2 Is Nothing Then
        MsgBox "No data shown by filter"

Virker efter hensigten

Hvad sker det hvis autofilter er aktivt men 0 rækker er valgt?

Hvad sker der hvis autofilter ikke er aktiv?

Da jeg testede det, gav begge muligheder msgbox'en hos mig.

Hvis søgning resulterer i 0 rækker og kopi funktionen aktiveres, returneres følgende fejl :

Runtime Error 424 - Object reqiured

Hvis alt er vist / filter ej aktivt kopieres samtlige rækker

Hmm - jeg må havet testet det inden det var færdigt. Jeg får fejl hvis der ikke er noget autofilter eller hvis 0 rækker er valgt. Det kan løses ved at tilføje

    Set r2 = Nothing

i begyndelsen. SÅ det er vel en løsning.

Ved ikke om det virker, men tester ved lejlighed. Det er ikke så relevant idet Copy funktionen / makroen kun kan aktiveres såfremt der er fremsøgt noget brugbart :-)

Takker for hjælpen

Er der en max grænse for hvor mange rækker rutinen kan håndtere ??

Af een eller anden grund får jeg pludselig fejl i copy rutinen ved indsætning efter række 32.775 !!!!

Det lyder som en Integer variabel, der skal være Long - grænsen er 32767 så vidt jeg husker. Det er derfor n er Long i min kode i #3.

Check din kode, og sørg for at ændre Integer til Long for de variable, der bruges til at tælle med, og se om ikke det hjælper.

Det var også min umiddelbare konklussion, men lige hvor i koden dette skal rettes kan jeg ikke se ( se koden )

Har forsøgt med Dim r AS Long, r2 As Long, d As Range

Sub CopyFilter()
    Dim r, r2, d As Range
    Dim n As Long
    Dim cYear, cStatus, cPage, cPrice
    Dim tStatus As String
    cYear = 2
    cStatus = 13
    cPage = 3
    cPrice = 11
    tStatus = "Fortsat i 2012"
   
    On Error Resume Next
        With ActiveSheet.AutoFilter.Range
            Set r2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            n = .Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
        End With
    On Error GoTo 0

    If r2 Is Nothing Then
        MsgBox "Ingen husdate data valgt !!!"
    Else
        'MsgBox n
        Set r = ActiveSheet.AutoFilter.Range
        Set d = r.Offset(r.Rows.Count, 0).Cells(1, 1)
        r.Offset(1, 0).Resize(r.Rows.Count - 1).Copy Destination:=d
        r.Offset(1, 0).Resize(r.Rows.Count - 1).Interior.ColorIndex = 15  'New
        d.Offset(0, cYear).Resize(n).Value = 2012
        d.Offset(0, cStatus).Resize(n).Value = tStatus
        d.Offset(0, cPage).Resize(n).Clear
        d.Offset(0, cPrice).Resize(n).Clear
   
        d.Offset(0, cPage).Resize(n).Select
       
    End If
   
End Sub

Hvilken fejl får du og ikke mindst i hvilken linie (det kan du se hvis du klikker debug)

Med koden som vist ovenfor stopper afviklingen af koden her :

Set d = r.Offset(r.Rows.Count, 0).Cells(1, 1)

Fejlmeddelelsen er :

Run-time 1004
Application-defined or object-defined error

Nogen løsning ???