Gefilterde gegevens verplaatsen naar een andere locatie

[reneemettrie]

Ik heb een listobject (insert table) waarop met VBA een filter werd gezet.

Met welke code kan ik de resulterende gegevens verwijderen uit het listobject en elders plakken?


Eerst kopiëren en plakken met de copy method en dan de tabelrijen verwijderen?

 

[HSV]

Recent.
https://www.helpmij.nl/forum/showth...-zoeken-en-knippen-en-plakken-naar-ander-blad

 

[HSV]

Nog even wat blijven proberen dan maar.

 

[reneemettrie]

Bedankt voor het linkje.
Had ondertussen ook één en ander geprobeerd.
Het kopiëren en plakken lukt met onderstaande.
Maar nu wou ik ook de gegevens in de oorspronkelijke tabel verwijderen.
Maar in het immediate venster wordt het aantal rijen van de zichtbare cellen verkeerd geteld, geeft altijd 1

Code:
Sub test()
Dim r As Range, source As Worksheet, dest As Worksheet
Set source = ActiveSheet

Set r = source.Range("A1").CurrentRegion

Set dest = Worksheets("paste")
r.Copy dest.Range("A1")


Set r = r.SpecialCells(xlCellTypeVisible)
Debug.Print r.Address
Debug.Print r.Rows.Count

'rijen verwijderen, behalve de headings
End Sub

Resultaat van debug (adres is correct maar aantal rijen niet)

$A$1:$C$1,$A$3:$C$3,$A$5:$C$5,$A$7:$C$7
 1

 

[VenA]

Da's komisch. HSV babbelt met zichzelf op dit forum.:d Dat de TS zijn/haar bericht weggehaald heeft komt dit forum voor de leesbaarheid natuurlijk alleen maar ten goede.:evil:

Wat wil je nu @reneemettrie? Warrige code plaatsen en verwijderen als er al op gereageerd is? Een oplossing krijgen voor een halfbakken vraag? O je hebt wat nieuws geplaatst.

 

[reneemettrie]

Da's komisch. HSV babbelt met zichzelf op dit forum.:d Dat de TS zijn/haar bericht weggehaald heeft komt dit forum voor de leesbaarheid natuurlijk alleen maar ten goede.:evil:

Wat wil je nu @reneemettrie? Warrige code plaatsen en verwijderen als er al op gereageerd is? Een oplossing krijgen voor een halfbakken vraag? O je hebt wat nieuws geplaatst.

Jouw commentaren zijn altijd zeer constructief moet ik zeggen (niet alleen op mijn vragen merk ik)
Vraag me trouwens af wat er warrig is aan mijn code. Of val je weer over mijn gebruik van Object variabelen?

 

[reneemettrie]

Mijn uiteindelijke code (kan warrig zijn maar werkt )
De filter werd al eerder in de code ingesteld, hier niet getoond

Sub test2()
Dim i As Integer, source As Worksheet, dest As Worksheet
Dim r As Range, t As ListObject
Set source = ActiveSheet
Set t = source.ListObjects(1)
Set dest = Worksheets("paste")
t.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy dest.Range("A1") 'of A2 als de titels er al instaan

Set r = t.DataBodyRange.Columns(1).SpecialCells(xlCellTypeVisible)
For i = 1 To r.Cells.Count
     r.Cells(1).EntireRow.Delete
Next i
t.AutoFilter.ShowAllData
End Sub

 

[VenA]

Waarom ga je gefilterde data rij voor rij verwijderen?

 

[reneemettrie]

Die vraag is terecht.
Mijn code was eerst een beetje anders, zonder een lisObject
Ik had toen gewoon geprobeerd met .... . rows.delete en dat werkte niet. Er werd telkens maar 1 rij verwijderd ipv allemaal.
Vanavond ga ik eens proberen of dat nu wel werkt.
Want ik neem aan dat het met een lus langer duurt (werkelijke tabel is heel groot)

 

[VenA]

Om maar eens een keertje constructief te zijn, wat blijkbaar niet mijn gewoonte is, er zijn zeer veel methoden om rijen te verwijderen. Bekijk dit linkje eens. De door jou gekozen optie is bij veel rijen veruit de beste optie als je veel geduld hebt.

 

[reneemettrie]

Bedankt voor het linkje. Hieronder mijn laatste versie. "0" seconden voor 30000 rijen.
Wat me wel opvalt is dat jij in het laatste voorbeeld met ENTIREROW werkt. Dat geeft bij mij een error.
ROWS (hetgeen gisteren om één of andere reden fout liep, vandaar mijn poging voor de lus) werkt nu correct

Sub KopieerEnVerplaats()

Dim i As Integer, source As Worksheet, dest As Worksheet, MyCell As Range
Dim r As Range, t As ListObject
Dim start As Long, finish As Long, CollapsedTime As Long

start = Timer()
Set source = ActiveSheet
Set t = source.ListObjects(1)
Set dest = Worksheets("paste")

dest.Cells.Clear

With t
    .HeaderRowRange.Copy dest.Range("A1")
    .DataBodyRange.SpecialCells(xlCellTypeVisible).Copy dest.Range("A2")
End With

Set r = t.DataBodyRange.SpecialCells(xlCellTypeVisible)

Application.DisplayAlerts = False
'r.EntireRow.Delete 'methode delete van de klasse range is mislukt
r.Rows.Delete

t.AutoFilter.ShowAllData

finish = Timer
CollapsedTime = finish - start
MsgBox "This took " & CollapsedTime & " seconds for 30000 rows"

End Sub

 

[HSV]

Je komt al aardig in de buurt van mijn eerste schrijven. :d

With t
    .HeaderRowRange.Copy dest.Range("A1")
    .DataBodyRange.SpecialCells(xlCellTypeVisible).Copy dest.Range("A2")
End With

waarschijnlijk..

 t.Range.SpecialCells(12).Copy dest.Range("A1")

 

[VenA]

Altijd jammer die halve code en geen bestand. In basis is dit voldoende

Sub VenA()
  With Sheet1.ListObjects(1).Range
    .AutoFilter 1, "Weetikveel"
    .SpecialCells(12).Copy Sheet2.Cells(1)
    .Offset(1).EntireRow.Delete
    .AutoFilter 1
  End With
End Sub

 

[HSV]

De basis is wat aan de grote kant.

.specialcells(12) mag je nog verwijderen