Rijen verplaatsen op basis van procenten. Lege cellen overslaan

Status
Niet open voor verdere reacties.

Tweety1

Gebruiker
Lid geworden
6 mrt 2013
Berichten
637
Ik gebruik onderstaan VBA om rijen te verplaatsen naar bepaalde tabbladen. Alleen loop ik tegen het volgende aan.
In kolom K komende de waardes 0%, 20%, 50%, 80%, 100% of helemaal leeg voor. De vba ziet de lege cellen als 0. Hoe kan ik deze uitsluiten zodat de lege cellen worden overgeslagen. Deze mogen blijven staan.


Code:
Private Sub CommandButton1_Click()
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
lRow = Sheets("Warme Klanten").Range("A50000").End(xlUp).Row
For j = lRow To 1 Step -1

    If Sheets("Warme Klanten").Range("K" & j) = 0# Then  '0%
        cRow = Sheets("Geen interesse").Cells(Rows.Count, "B").End(xlUp).Row
        Sheets("Warme Klanten").Rows(j).Copy Destination:=Sheets("Geen interesse").Range("A" & cRow + 1)
        Sheets("Warme Klanten").Rows(j).Delete
    ElseIf Sheets("Warme Klanten").Range("K" & j) = 0.2 Then  '20%
        cRow = Sheets("Overig (koud)").Cells(Rows.Count, "B").End(xlUp).Row
        Sheets("Warme Klanten").Rows(j).Copy Destination:=Sheets("Overig (koud)").Range("A" & cRow + 1)
        Sheets("Warme Klanten").Rows(j).Delete

End If
Next

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    
End Sub
 
Laatst bewerkt:
Controleer dat met: .SpecialCells(xlCellTypeConstants)
Of plaats een voorbeeld document.
 
Laatst bewerkt:
Probeer het eens zo:
Code:
Private Sub CommandButton1_Click()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    With Sheets("Warme Klanten")
        For j = .Range("A50000").End(xlUp).Row To 1 Step -1
            Select Case Cells(j, "K").Value
                Case ""
                Case 0#
                    cRow = Sheets("Geen interesse").Cells(Rows.Count, "B").End(xlUp).Row
                    .Rows(j).Copy Destination:=Sheets("Geen interesse").Range("A" & cRow + 1)
                    .Rows(j).Delete
                Case 0.2
                    cRow = Sheets("Overig (koud)").Cells(Rows.Count, "B").End(xlUp).Row
                    .Rows(j).Copy Destination:=Sheets("Overig (koud)").Range("A" & cRow + 1)
                    .Rows(j).Delete
            End Select
        Next j
    End With
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub
 
Laatst bewerkt:
Ok, dan is deze nog een stukje netter voor als je die 50, 80 en 100 er ook nog bij maakt:
Code:
Private Sub CommandButton1_Click()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    With Sheets("Warme Klanten")
        For j = .Range("A50000").End(xlUp).Row To 1 Step -1
            Select Case Cells(j, "K").Value
                Case "": sht = ""
                Case 0#: sht = "Geen interesse"
                Case 0.2: sht = "Overig (koud)"
                Case 0.5: sht = "sheet voor 50%"
                Case 0.8: sht = "sheet voor 80%"
                Case 1#: sht = "sheet voor 100%"
            End Select
            If sht <> "" Then
                cRow = Sheets(sht).Cells(Rows.Count, "B").End(xlUp).Row
                .Rows(j).Copy Destination:=Sheets(sht).Range("A" & cRow + 1)
                .Rows(j).Delete
                sht = ""
            End If
        Next j
    End With
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub
 
Laatst bewerkt:
Een beetje weinig informatie over hoe de tabjes heten en of deze al bestaan.

Code:
Sub VenA()
  ar = Sheets("Excel Formules").Cells(22, 1).CurrentRegion
  With Sheets("Warme Klanten").Cells(1).CurrentRegion
    For j = 1 To UBound(ar)
      c00 = ar(j, 1) * 100 & "%"
        .AutoFilter 11, c00
        If IsError(Evaluate("'" & c00 & "'!A1")) Then
          Sheets.Add(, Sheets(Sheets.Count)).Name = c00
          .Copy Cells(1)
         Else
          .Offset(1).Copy Sheets(c00).Cells(Rows.Count, 1).End(xlUp).Offset(1)
        End If
      .Offset(1).EntireRow.Delete
    Next j
    .AutoFilter
  End With
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan