Knippen van niet aaneengesloten gebieden in makro

[Abco_B]

Met hulp van een aantal forum leden heb ik onderstaande makro samengesteld:



Sub Gereedmelden()

Application.ScreenUpdating = False

Dim WB As Variant
WB = ActiveSheet.Name

Dim c As Range
For Each c In ActiveWindow.RangeSelection
Range("O" & c.Row) = Now
Next

Selection.EntireRow.Select
Selection.Cut
Worksheets("Gereed").Activate

Eerste_lege_rij

ActiveSheet.Paste
ActiveCell.Offset(1, 0).Range("A1").Select
Worksheets(WB).Select
Selection.Delete Shift:=xlUp
ActiveCell.Select

End Sub



Deze makro meldt storingsmeldingen gereed door een datum in kolom O te plaatsen, de meldingen te knippen en in het blad gereed te plaatsen.
Zolang er meerdere cellen of rijen aaneengesloten geselecteerd zijn, werkt de makro.

Als ik echter de meldingen in rij 2 en 4 wil gereedmelden gaat dit niet, omdat knippen alleen werkt voor aaneengesloten gebieden.

Als ik toch in één handeling/makro de meldingen in 2 of meer geselecteerde rijen wil gereedmelden, moet ik dan sorteren (op kolom O) in de makro opnemen voordat ik ga knippen of is er een mooiere oplossing ? Vast wel ...

Abco

 

[jheesterbeek]

met do while...loop zou je het hele sheet door kunnen lopen en alle regels die voldoen aan het criteria kopieeren naar het andere sheet.
Het is iets omslachtiger, maar zal in tijd (met een macro) niet opvallend veel verschil maken.

 

[Abco_B]

Dank voor je reactie.

Ik heb ondertussen iets in die trend gevonden, zal de maandag de oplossing even plakken.

Abco

 

[Abco_B]

Zoals gezegd, "mijn" oplossing. Ik heb er, met hulp en macro's van dit forum, onderstaande macro van gemaakt.


Sub Melding_gereedmelden()

Application.ScreenUpdating = False

Datum_gereed

Dim WB As Variant
WB = ActiveSheet.Name

Dim q As Variant
For Each q In Range("O:O")
If q = Date Then
q.EntireRow.Cut
Worksheets("Gereed").Activate
Eerste_lege_rij
ActiveSheet.Paste
Eerste_lege_rij
Worksheets(WB).Select
End If
Next

Lege_rijen_verwijderen

Application.ScreenUpdating = True
Eerste_lege_rij

End Sub




Sub Datum_gereed()

Application.ScreenUpdating = False

Dim C As Range
For Each C In ActiveWindow.RangeSelection
Range("O" & C.Row) = Date
Next

End Sub




Sub Lege_rijen_verwijderen()

Dim R As Long
Dim C As Range
Dim N As Long
Dim rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
Set rng = Selection
Else
Set rng = ActiveSheet.UsedRange.Rows
End If
N = 0
For R = rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then
rng.Rows(R).EntireRow.Delete
N = N + 1
End If
Next R

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub



Als dingen handiger of beter kunnen, hoor ik het graag ...