Archiwa tagu: warunkowe usuwanie

Warunkowe usuwanie wierszy

Opublikowany przez
Odpowiedz

Spory kawałek kodu jak na tak prosty w sumie problem a to dlatego, że aplikacja sprawdza sobie najpierw czy ma z czym pracować i na dodatek robi kopię skasowanych wierszy

Option Explicit
 
Public Const WERSJA = "Warunkowe usuwanie wierszy v.1.0 (Akademia-VBA.pl)"
Public Const KOL_SPRAWDZANA As Long = 3
'
' Usuwa wiersz zakresu z nagłówkami gdy w kolumnie 3 jest pusto
' Usunięte wiersze zapisuje na wszelki w dodatkowym arkuszu
' Wcześniej aplikacja sprawdza, czy są dane
' i czy użytkownik ustawił w nich komórkę aktywną
'
 
Sub WarunkoweUsuwanieWierszy()
    Dim Zakres As Range
    Dim LW As Long, W As Long
    Dim Wiersz As Range
    Dim x As Long
    Dim ArkUsuwanychWierszy As Worksheet
    Dim Naglowki As Range
 
    If NienormalnyArkusz Then Exit Sub
    If NienormalneOkno Then Exit Sub
    If BrakZakresu Then Exit Sub
 
    Set Zakres = ActiveCell.CurrentRegion
    Set Naglowki = Zakres.Rows(1)
    Set ArkUsuwanychWierszy = Sheets.Add()
    ArkUsuwanychWierszy.Name = "Skasowane" & StempelCzasowy
    Naglowki.Copy ArkUsuwanychWierszy.Range("A1")
 
    LW = Zakres.Rows.Count
 
    For W = LW To 2 Step -1
        Application.StatusBar = "Analiza wiersza " & W
 
        If Len(Zakres.Cells(W, KOL_SPRAWDZANA)) = 0 Then 'czyli gdy pusto
            x = x + 1
            Set Wiersz = Zakres.Rows(W)
            Wiersz.Copy ArkUsuwanychWierszy.Cells(x + 1, 1)
            Wiersz.Delete
        End If
    Next
    ArkUsuwanychWierszy.UsedRange.EntireColumn.AutoFit
    Application.StatusBar = False
    MsgBox "Poczatkowa liczba wierszy: " & LW & vbNewLine & _
            "Liczba wierszy usuniętych: " & x & vbNewLine & _
            "Pozostało wierszy: " & LW - x, vbInformation, WERSJA
End Sub
 
Private Function NienormalnyArkusz() As Boolean
    If ActiveSheet.Type <> xlWorksheet Then
        MsgBox "Ustaw się w arkuszu danych!", vbExclamation, WERSJA
        NienormalnyArkusz = True
    End If
End Function
 
Private Function NienormalneOkno() As Boolean
    If ActiveWindow.Type <> xlWorkbook Then
        MsgBox "Ustaw się w oknie danych!", vbExclamation, WERSJA
        NienormalneOkno = True
    End If
End Function
 
Private Function BrakZakresu() As Boolean
    If Len(ActiveCell) = 0 Then
        MsgBox "Ustaw się w niepustej komórce zakresu danych!", vbExclamation, WERSJA
        BrakZakresu = True
    End If
End Function
 
Function StempelCzasowy() As String
    StempelCzasowy = Format(Now(), "_yyyymmdd_hhmmss")
End Function