VBA code regel verwijderen als waarde in Kolom Q een 1 is

[Lifeline25]

Goedenmiddag,

Ik ben momenteel aan het proberen een macro te maken waarbij elke regel verwijderd moet worden als de waarde in kolom Q een 1 is.

De waarden in Kolom Q kunnen een 1 of een 0 zijn (som.als functie in die kolom).

Is er toevallig iemand die dit al ooit heeft uitgezocht en de VBA code voor een dergelijke macro heeft?

Mvg,
Dave

 

[Superzeeuw]

Dave,

Zet eens een autofilter op kolom Q die alles laat zien dat 1 is.
Selecteer daarna je resultaat en verwijder alle regels.

Sneller kan niet en zonder VBA.

 

[Lifeline25]

Dave,

Zet eens een autofilter op kolom Q die alles laat zien dat 1 is.
Selecteer daarna je resultaat en verwijder alle regels.

Sneller kan niet en zonder VBA.

Hey Superzeeuw,

Dankje voor je antwoord. Die optie heb ik zelf ook al overwogen, echter het document moet "monkey-proof" worden, met andere woorden ik ben bezig een document te maken waarbij iemand dit kan doen met 1 druk op de knop.
Dat de macro tijd in beslag zal nemen om alle regels te verwijderen is geen bezwaar.

 

[snb]

Neem deze handelingen op met de macro-editor en je hebt....
Daarna nog wel even code wieden.

 

[Lifeline25]

Neem deze handelingen op met de macro-editor en je hebt....
Daarna nog wel even code wieden.

Inmiddels ben ik er uit, ik heb het volgende gedaan en het werkt perfect:

Sub sorteren()
'
' sorteren Macro
'
'
Application.ScreenUpdating = False

'
Sheets("nieuwe outboundoverzicht").Select
Columns("A:Q").Select
Range("Q1").Activate
Application.CutCopyMode = False
Selection.Sort Key1:=Range("Q1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers

Sheets("nieuwe outboundoverzicht").Select
Columns("Q:Q").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False



For Row = 1 To 5000
If Cells(Row, 17).Value = 1 Then
Rows(Row).Delete
End If
Next

For Row = 1 To 5000
If Cells(Row, 17).Value = 1 Then
Rows(Row).Delete
End If
Next

Sheets("nieuwe outboundoverzicht").Select
ActiveWorkbook.Sheets("nieuwe outboundoverzicht").Tab.ColorIndex = 4

Sheets("dashboard").Select

Application.ScreenUpdating = True

End Sub

In ieder geval bedankt voor jullie reacties!

 

[Interface]

ik zou het zo doen.

Sub DeleteRows()

Dim i As Integer

Application.ScreenUpdating = False

With Sheets("nieuwe outboundoverzicht")
    For i = 1 To 5000
        If .Range("q" & i) = 1 Then .Range("q" & i) = vbNullString
    Next i
    .Range("q1:q5000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

Application.ScreenUpdating = True

End Sub

 

[Lifeline25]

Dankje voor je reactie, inmiddels heb ik het zelfs weer anders opgelost:

Sub ontdubbelen()
'
' ontdubbelen Macro
' De macro is opgenomen op 26-4-2010.
'
Application.ScreenUpdating = False

'
Sheets("nieuwe outboundoverzicht").Select
Columns("A:Q").Select
Range("Q1").Activate
Application.CutCopyMode = False
Selection.Sort Key1:=Range("Q1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers

Sheets("nieuwe outboundoverzicht").Select
Columns("Q:Q").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("nieuwe outboundoverzicht").Select
Columns("A:R").Select
Range("R1").Activate
Selection.AutoFilter
Selection.AutoFilter Field:=18, Criteria1:="1"
Rows("2:2761").Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=18, Criteria1:="4237"
Selection.Delete Shift:=xlUp
Selection.AutoFilter
Sheets("Dashboard").Select
Sheets("nieuwe outboundoverzicht").Select
ActiveWorkbook.Sheets("nieuwe outboundoverzicht").Tab.ColorIndex = 4

Sheets("dashboard").Select

Application.ScreenUpdating = True

End Sub

doodsimpel een autofilter er overheen laten lopen... ik kan mezelf wel voor mijn kop slaan nu...

 

[snb]

Dood'simpel' ?
Wanneer ga je code wieden ?

With Sheets("nieuwe outboundoverzicht").usedrange.Columns("A:R")
  .AutoFilter 18, "1",xlor ,"4237"
  .offset(1).specialcells(xlcelltypevisible).entirerow.delete
  .Autofilter
End With