rijen verwijderen op basis van waarden en vervolgens een sorrtering toepassen met vba

[Depant]

Hallo allemaal,

Ik wil graag alle rijen verwijderen waar < 1 ,1,2 in kolom B staan.
Ik wil graag alle rijen kopieren ( naar tabblad twee) waarin er een 1 staat in de kolommen l,m,n,o of p.
Er staat er dus altijd maar 1 ( bij l,m,n,o,p of helemaal niks)

Kan iemand hier iets mee
Normaal is het bestand 15000 regels of zo maar dat maakt verder niks uit

Groeten Henk

 

[VenA]

Klopt de volgorde van de handelingen wel? Na het verwijderen van de rijen blijft en in het voorbeeldbestand niets meer over om te kopiëren. Het < 1 teken maakt het filteren er niet makkelijker op. Deze heb ik dmv code maar even vervangen. Om de rijen te verwijderen dmv een filter:

Sub VenA()
With Cells(1).CurrentRegion.Offset(1)
    .Columns(2).Replace "< 1", "|"
    .AutoFilter 2, Array("|", "1", "2"), 7
    .Offset(1).EntireRow.Delete
    .AutoFilter
End With
End Sub

Hoe je de rest weggeschreven wil hebben is mij onduidelijk. Waarom staan er ontzettend veel op het oog lege cellen in dit bestand?

 

[HSV]

Sub hsv()
With Cells(1).CurrentRegion.Offset(1)
    .AutoFilter 2, Array("=< 1", "1", "2"), 7
    .Offset(1).EntireRow.Delete
    .AutoFilter
End With
End Sub

 

[VenA]

Hoe simpel kan het zijn:d

 

[HSV]

Ja, kom er maar op.

Zo zou de volledige code moeten luiden indien er ook nog wat gegevens overbleven om te kopieren.

Sub hsv()
Dim j As Long
With Cells(1).CurrentRegion.Offset(1).Resize(, 16)
    .AutoFilter 2, Array("=< 1", "1", "2"), 7
    .Offset(1).EntireRow.Delete
    .AutoFilter
      For j = 12 To 16
       .AutoFilter j, 1
      Next j
      .SpecialCells(12).Copy Sheets("twee").Cells(1)
    .AutoFilter
End With
End Sub

 

[HSV]

Of misschien wel zo.

Sub hsv()
Dim j As Long
 With Cells(1).CurrentRegion.Offset(1).Resize(, 16)
    .AutoFilter 2, Array("=< 1", "1", "2"), 7
    .Offset(1).EntireRow.Delete
    .AutoFilter
      For j = 12 To 16
        .AutoFilter j, 1
        .Offset(1).SpecialCells(12).Copy Sheets("twee").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
      Next j
 End With
End Sub

 

[Depant]

hallo allemaal

Super bedankt allemaal,

Ik heb niks met vba
Maar een paar keer per jaar moet ik er wat mee tobben...
Ik ben er weer bijna.
Maar voordat ik de macro laat lopen moet ik het hele tabblad selecteren anders vervangt hij niet.
Ik heb mijn versie nu hier gezet.
Kunnen jullie er nog iets mee.

 

[plongske]

even vergeten uw versie te uploaden?

 

[HSV]

Sub hsv()
Dim j As Long
With[COLOR=#FF0000] sheets("mis").[/COLOR]Cel[COLOR=#FF0000][/COLOR]ls(1).CurrentRegion.Offset(1).Resize(, 16)
    .AutoFilter 2, Array("=< 1", "1", "2"), 7
    .Offset(1).EntireRow.Delete
    .AutoFilter
      For j = 12 To 16
       .AutoFilter j, 1
      Next j
      .SpecialCells(12).Copy Sheets("twee").Cells(1)
    .AutoFilter
End With
End Sub

 

[Depant]

Hallo Harry,

Ik heb nu deze

Sub hsv()
Dim j As Long
With Sheets("mis").Cells(1).CurrentRegion.Offset(1).Resize(, 16)
.AutoFilter 2, Array("=< 1 ", "1", "2"), 7
.Offset(1).EntireRow.Delete
.AutoFilter
For j = 12 To 16
.AutoFilter j, 1
Next j
.SpecialCells(12).Copy Sheets("twee").Cells(1)
.AutoFilter
End With
End Sub


Maar ik zou graag willen dat hij kolom 11 tot 16 sorteert op "1"
En de rijen die dus kolom 11 tot en met 16 een 1 hebben wegkopieert.

 

[HSV]

Dan moet je het zo maar eens weer testen Henk.

Sub hsv()
Dim j As Long
Application.ScreenUpdating = False
 With Sheets("mis").Cells(1).CurrentRegion.Offset(1).Resize(, 16)
    .AutoFilter 2, Array("=< 1", "1", "2"), 7
    .Offset(1).EntireRow.Delete
    .AutoFilter
      For j = 11 To 16
        .AutoFilter j, 1
        .Offset(1).SpecialCells(12).Copy Sheets("twee").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
      Next j
    .Sort .Parent.Cells(2, 14), , .Parent.Cells(2, 15), , , .Parent.Cells(2, 16), , xlYes
    .Sort .Parent.Cells(2, 11), , .Parent.Cells(2, 12), , , .Parent.Cells(2, 13), , xlYes
 End With
End Sub

 

[Depant]

Bedankt

Hallo allemaal,

Bedankt voor de moeite.
Het werkt uitstekend.
Voor mij is het pure magie.

Henk Harbers