vba kopieren plakken met voorwaarden

[moensk]

tabblad "data" wordt maandelijks ververst
ik wil de rijen verdelen over 2 tabbladen >0 (in) en <0 (uit)
1. ik wil maar enkele kolommen overzetten (geel in voorbeeld)
2. moet geplakt worden in eerst volgende lege rij want deze groeit verder

had iets in mekaar gestoken via "autofilter" doch krijg het niet in orde en hij kopieert kop mee

graag jullie hulp

Sub RijenVerplaatsen()
    With Sheets("data")
        .Range("A:R").AutoFilter Field:=9, Criteria1:=">0", Operator:=xlAnd
        .Range(.Range("A1:R1"), .Range("A1").End(xlDown)).Copy
    End With
    Sheets("in").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
    Sheets("data").Range("A:R").AutoFilter
End Sub

 

[peter59]

Hallo,

Zoiets?
Maar nu met power query.

 

[AHulpje]

Powerquery, krachtig, compact en snel. Maar met VBA kan het ook:

Option Explicit

Sub RijenVerplaatsen()
    KopieerRijen ("in")
    KopieerRijen ("uit")
End Sub


Function KopieerRijen(InUit)
    Dim lastrow As Long
    With Sheets("data")
        If InUit = "in" Then
            .Range("A:R").AutoFilter Field:=9, Criteria1:=">0", Operator:=xlAnd
        Else
            .Range("A:R").AutoFilter Field:=9, Criteria1:="<0", Operator:=xlAnd
        End If
        lastrow = .Range("A2").End(xlDown).Row
        Union( _
        .Range("E2", "E" & lastrow), _
        .Range("F2", "F" & lastrow), _
        .Range("G2", "G" & lastrow), _
        .Range("I2", "I" & lastrow), _
        .Range("R2", "R" & lastrow)).Copy
        Sheets(InUit).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
        .Range("A:R").AutoFilter
    End With
End Function

 

[moensk]

AHulpje,
script werkt goed, nog één vraagje

in tabblad "in" en "uit" wil ik veld 7 = kolom G en veld 6 = kolom I van plaats gewisseld hebben.
ik krijg het niet voor mekaar met u script

 

[AHulpje]

Da's niet zo moeilijk.
Simpelweg twee regels omwisselen:

.Range("I2", "I" & lastrow), _
.Range("G2", "G" & lastrow), _
wordt
.Range("G2", "G" & lastrow), _
.Range("I2", "I" & lastrow), _

En natuurlijk even de kopteksten op de werkbladen In en Uit aanpassen.

 

[moensk]

Ahulpje
had ik geprobeerd en krijg ze niet gewisseld
ik upload bestand, kunt gij even kijken aub

 

[AHulpje]

Excuus, slordigheidje van mijn kant, had natuurlijk moeten zijn:

.Range("G2", "G" & lastrow), _
.Range("I2", "I" & lastrow), _

wordt

.Range("I2", "I" & lastrow), _
.Range("G2", "G" & lastrow), _

In bijgaande versie is dat aangepast.

 

[moensk]

Ahulpje
hoi, ik heb G en I al 10x gewisseld
ik heb u excel gedownload en is nog niet aangepast
kijk even in tabblad "in" heb daar kort samengevat
alvast bedankt

 

[AHulpje]

Excuus, ik had het zelf niet goed getest, UNION sorteert de ranges op alfabet, dat was mij ontschoten.
In bijgaande versie worden de diverse kolommen als aparte ranges behandeld.

 

[JEC.]

Van mij ook nog een alternatief. Deze is aanzienlijk sneller.

Sub jec()
 Dim ar
 ar = Sheets("data").Cells(1).CurrentRegion.Value2
 ar = Application.Index(ar, Evaluate("row(2:" & UBound(ar) & ")"), Array(5, 6, 9, 7, 18))
 Application.ScreenUpdating = False
 
 With Sheets("in").Range("D1")
   .Parent.Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(ar), UBound(ar, 2)) = ar
    With .CurrentRegion
      .AutoFilter 3, "<0"
      .Offset(1).EntireRow.Delete
      .AutoFilter
    End With
 End With
 With Sheets("uit").Range("D1")
   .Parent.Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(ar), UBound(ar, 2)) = ar
    With .CurrentRegion
      .AutoFilter 3, ">0"
      .Offset(1).EntireRow.Delete
      .AutoFilter
    End With
 End With
End Sub

 

[AHulpje]

De methode met Evaluate had ik ook geprobeerd, maar die nam ook de uitgefilterde rijen mee.
Maar als je die pas weggooit uit het In en Uit werkblad na het kopiëren dan bereik je hetzelfde resultaat, slim bedacht!

P.S.
Hoeft Application.ScreenUpdating niet weer aangezet te worden na afloop?

 

[JEC.]

Thanks!
Application.Screenupdating wordt te allen tijde weer terug op TRUE gezet na het runnen van de macro (in tegenstelling tot EnableEvents).

 

[moensk]

Jec
Wat dien ik te wijzigen aan script zodat hij in tabblad "in" en uit" plakt vanaf D2
Ahulpje
u script kan ik beter lezen en was het simpel om te laten plakken op D2

 

[JEC.]

Code hierboven is aangepast. Kijk maar of dit juist is

 

[moensk]

Jec
hij kopieert naar de juiste plaats doch in beide tabbladen "in" en "uit" zet hij alles
de > en < werkt niet
kan u hier even naar kijken aub

 

[JEC.]

Vermoedelijk omdat er meer data dan alleen je gewenste data in die tabbladen staat. Plaats dan een representatief voorbeeldbestand.

 

[moensk]

Jec,
ik heb u script in mijn voorbeeld bestandje geplakt en doet hij hetzelfde
hij kopieert alles naar de "in" en de "uit"
in bijlage de excel met u script

 

[JEC.]

Zoals verwacht staan er 3 kolommen voor, dan is de currentregion anders.
De kolom waarop gefilterd wordt, moet je dus aanpassen naar 6 in dit geval.

Als je met F8 door de code was gegaan, had je gezien dat er werd gefilterd in kolom C.

Sub jec()
 Dim ar
 ar = Sheets("data").Cells(1).CurrentRegion.Value2
 ar = Application.Index(ar, Evaluate("row(2:" & UBound(ar) & ")"), Array(5, 6, 9, 7, 18))
 Application.ScreenUpdating = False
 
 With Sheets("in").Range("D1")
   .Parent.Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(ar), UBound(ar, 2)) = ar
    With .CurrentRegion
      .AutoFilter 6, "<0"
      .Offset(1).EntireRow.Delete
      .AutoFilter
    End With
 End With
 With Sheets("uit").Range("D1")
   .Parent.Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(ar), UBound(ar, 2)) = ar
    With .CurrentRegion
      .AutoFilter 6, ">0"
      .Offset(1).EntireRow.Delete
      .AutoFilter
    End With
 End With
End Sub

 

[AHulpje]

Maak er eens
.AutoFilter 6, "<0"
en
.AutoFilter 6, ">0"
van.
Snap je waarom?

 

[JEC.]

Als je office 365 hebt kun je het ook af met een filter formule

=LET(x;FILTER(data!E2:R6;data!I2:I6>0);INDEX(x;REEKS(RIJEN(x));{1\2\5\3\14}))
en
=LET(x;FILTER(data!E2:R6;data!I2:I6<0);INDEX(x;REEKS(RIJEN(x));{1\2\5\3\14}))