Macro untuk menghapus row yang kosong

Seringkali  kita  harus  merapikan  data-data yg  di download dari  server misal nya SAP, tidak terformat seperti apa  yg di inginkan.
Header  yang  berulang , row  yang  kosong dan sebagai nya, untuk  bisa menganalisa  data lebih jauh. tentunya  format nya harus  kita rapikan.
Seperti gambar  di bawah..

Row 6,7,10 dan 11 ( warna kuning )  tentunya  tidak dibutuhkan.harus  di hapus.
iya  kalau  datanya sedikit..hanya  beberapa baris, tentunya tidak membutuhkan waktu lama.
Bagaimana Jika  data  yg di download berisi  ribuan baris, pasti sangat  tidak efektif dan membosankan.
apalagi harus di lakukan setiap kali setelah download.
nah untuk  mempermudah menghapus data-data yg kosong ataupun row yang tidak di butuhkan,
salah satu solusi nya bisa menggunakan macro berikut:

Sub menghapusrow()

    Dim rng As Range
    Dim calcmode As Long
    Dim myArr As Variant
    Dim I As Long

    With Application
        calcmode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'isi data yg akan di hapus , atau pun row yang kosong
    myArr = Array("Material", "")

    For I = LBound(myArr) To UBound(myArr)

        'pilih sheet yg ingin data nya di hapus( bisa juga di asign nama sheet nya)
        With ActiveSheet

            'pertama hilangkan auto filter
            .AutoFilterMode = False

            'buat auto filter berdasarkan colom yang yg data nya mau di hapus
            .Range("D1:D" & .Rows.Count).AutoFilter Field:=1, Criteria1:=myArr(I)

            Set rng = Nothing
            With .AutoFilter.Range
                On Error Resume Next
                Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                          .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rng Is Nothing Then rng.EntireRow.Delete
            End With

            'hilangkan auto filter
            .AutoFilterMode = False
        End With

    Next I

    With Application
        .ScreenUpdating = True
        .Calculation = calcmode
    End With

End Sub


Post a Comment

2 Comments