Marco - regel verplaatsen naar ander tabblad+formules verwijderen+meerdere te gelijk

[Johan09]

Goedemorgen,

Doormiddel van een macro wil ik data van een tabblad verwijderen en verplaatsen naar een ander door het geven van een bepaalde status. Dit werkt, echter kom ik de volgende hindernissen tegen.
1. de macro verplaatst ook de formules uit het oorspronkelijke tabblad en ik wil dat er alleen waardes en opmaak geplakt worden.
2. als ik de status verander van meerdere cellen dan verplaatst de macro steeds maar 1 regel naar het "tabblad1"

gr Johan

hieronder de Macro:

Sub Macro4()

Dim rij As Long
Dim n As Long
Dim src As Worksheet
Dim trg As Worksheet
Set src = Sheets("formule+overview")
Set trg = Sheets("blad1")
Application.ScreenUpdating = False

rij = trg.[A65536].End(xlUp).Row + 1

For n = 1 To Blad1.[A65536].End(xlUp).Row
If Cells(n, "D").Value = "done" Then
Range(Cells(n, "A"), Cells(n, "OG")).Copy
trg.Cells(rij, "A").PasteSpecial

Range(Cells(n, "A"), Cells(n, "OG")).EntireRow.Delete

rij = rij + 1
End If
Next

Application.Goto [blad2!A1], True
Application.Goto [blad1!A1], True
Application.ScreenUpdating = True
End Sub

 

[VenA]

Het blijft altijd lastig. Code even tussen codetags een voorbeeldje plaatsen even de zoekfunctie gebruiken......... Gebruik het autofilter voor dit soort acties.

Dus maar een beetje op de gok.

Sub VenA()
With Blad1.Cells(1).CurrentRegion
    .AutoFilter 4, "Done"
    .Offset(1).Copy Blad2.Cells(Rows.Count, 1).End(xlUp)(2)
    .Offset(1).EntireRow.Delete
    .AutoFilter
End With
End Sub

 

[MDN111]

Dag Johan09,

Misschien kan je hier wel verder op borduren. Zie bijlage.

Grtz,
MDN111.

 

[MDN111]

Oei! terwijl het bericht bij nog open stond, heeft VenA reeds geantwoord.
Had is niet gemerkt.
Sorry, VenA.

Grtz,
MDN111.

 

[VenA]

Is geen excuus voor nodig. Overkomt mij ook regelmatig.:d

 

[Johan09]

Dank u :thumb: erg overzichtelijk

 

[Johan09]

toch nog een aanvullende vraag. hoe kan ik meerdere opties toevoegen: dus niet alleen status done naar tabblad 1 maar bijvoorbeeld status tijdelijk naar tabblad 2

 

[VenA]

Bv zo

Sub VenA()
Ar = Array("done", "tijdelijk")
For j = 0 To UBound(Ar)
With Blad1.Cells(1).CurrentRegion
    .AutoFilter 4, Ar(j)
    .Offset(1).Copy Sheets(j + 2).Cells(Rows.Count, 1).End(xlUp)(2)
    .Offset(1).EntireRow.Delete
    .AutoFilter
End With
Next j
End Sub

 

[Johan09]

aanvullend informatie gevraagd aangaande je oplossing

Ik gebruik nu wat jij hebt gemaakt in je voorbeeld Excel. Daar dit eenvoudig te volgen is. hoe zet ik die extra optie hier in?

gr Johan

Sub MoveSomeRows()

Dim rij As Long, n As Long, src As Worksheet, trg As Worksheet
Dim nLastRow As Long
Set src = Sheets("formule+overview")
Set trg = Sheets("blad1")

Application.ScreenUpdating = False

'We gaan er van uit dat er geen lege rijen in de browsheet staan. Zodra we
'een rij ontmoeten met een lege cel in de eerste kolom, is het gedaan.
'We beginnen op de 2de rij.
rij = 2
Do While Not (IsEmpty(src.Cells(rij, 1)))
    If src.Cells(rij, StatusColumn).Value = "dome" Then
    
        'Deze rij kopiëren naar het Clipboard
        src.Cells(rij, StatusColumn).EntireRow.Copy
        
        'De laatste gegevensrij van de target-sheet opzoeken.
        nLastRow = LastRow(trg)
        
        'Waarden en formats in de target-sheet pasten.
        trg.Cells(nLastRow + 1, 1).PasteSpecial
        trg.Cells(nLastRow + 1, 1).PasteSpecial Paste:=xlPasteFormats
        
        'Deze rij in de source-sheet deleten.
        src.Cells(rij, StatusColumn).EntireRow.Delete Shift:=xlShiftUp
        
        'Door het deleten schuiven de resterende rijen één rij naar boven.
        'Dat moeten we compenseren.
        rij = rij - 1
    
    End If
    
    'Volgende rij.
    rij = rij + 1
Loop

'Door het pasten wordt de target-sheet de ActiveSheet, maar de source-sheet
'was actief bij de start van de macro. Deze activeren we opnieuw.
src.Activate

Application.ScreenUpdating = True

End Sub

Public Function LastRow(oSh) As Long
On Error Resume Next
With oSh
    LastRow = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
End With
End Function

 

[VenA]

Waar reageer je eigenlijk op?

 

[Johan09]

sorry, op het bericht van MDN111.

 

[VenA]

Gewoon de code van MDN111 doorgronden en deze aanpassen of deze code weggooien en de code uit #8 gebruiken. Eventueel aanpassen naar de juiste tabjes/filteropties.

 

[MDN111]

@Johan09
De code van VenA is een stuk mooier, maar misschien moeilijker te doorgronden. Mocht je toch besluiten om de code uit #9 te gebruiken, vervang dan de regel

If src.Cells(rij, StatusColumn).Value = "dome" Then

door

If Not IsEmpty(src.Cells(rij, StatusColumn)) And InStr("done*tijdelijk", src.Cells(rij, StatusColumn).Value) <> 0 Then

@VenA
Zoals ik al zei, is jou code veel mooier maar niet van de gemakkelijkste. Ik slaag er namelijk niet in om ze volledig te doorgronden. Vandaar deze vraag:

Kan je even de vermelding "(2)" verduidelijken in de regel

.Offset(1).Copy Sheets(j + 2).Cells(Rows.Count, 1).End(xlUp)[COLOR="#FF0000"](2)[/COLOR]

Grtz,
MDN111.

 

[Johan09]

Oke thanks.
Hoe zorg ik dat de status "Tijdelijk" dan op een ander tabblad komt te staan dan de status "done"?

 

[VenA]

@MDN111
De (2) kan je lezen als .offset(1).

Jouw code gaat volgens mij niet werken omdat er naar verschillende tabjes weggeschreven moet worden. En statuscolumn krijgt volgens mij nergens een waarde. (maar dit komt geloof ik niet uit jouw koker):d

 

[VenA]

De code uit #8 doet wat u vraagt. Wel even zelf toepassen in uw eigen bestandje. Of het bestandje even hier plaatsen dan doe ik het wel even.

 

[MDN111]

Ja, ik heb de vraag in #7 niet goed gelezen en dus niet gezien dat er moet weggeschreven worden naar een andere sheet in functie van de status. Sorry!
In bijlage een nieuw bestand met gewijzigde code.

@VenA

1. Bedankt voor de toelichting over de offset.
3. In het bestandje dat ik bij #3 had bijgevoegd, was StatusColumn gedeclareerd als Private Const met waarde 5, maar Johan09 heeft dat niet mee gekopieerd naar #9.

Grtz,
MDN111.