FILTER KELOMPOK DATA USING VBA

Sub Data_fillter()

 ActiveSheet.Range("A6:F200").Value = ""

Sheets("data").Range("A7:F200").Copy

ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues

Range("A1").Select

Dim row As Long

LastRow = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 4).End(xlUp).row

row = 6

For row = LastRow To row Step -1

If Cells(row, 6) <> Range("F3") Then

Cells(row, 6).EntireRow.Delete

End If

Next row

End Sub

 UNDUH SAMPEL FILE >>>>>   Filter Kelompok Data

Filter Nilai Penjualan Tenggang Waktu - Belajar VBA EXCEL

Private Sub Worksheet_Change(ByVal Target As Range)

 If Target.Address = [L1].Address Then

     Call Filter_Tgl

 End If

End Sub

Sub Filter_Tanggal()

Dim TglAwal As Date

Dim i As Long, Interval As Long

With Sheets("Sheet2")

If .FilterMode Then AutoFilter = False

    TglAwal = Format(.Range("L1").Value, "dd/mm/yyyy")

    Interval = (.Range("L2") - .Range("L1")) + 1

    i = TglAwal

    .Range("B4").AutoFilter Field:=1, Criteria1:=">=" & i, Operator:=xlAnd, Criteria2:="<" & i + Interval

End With

End Sub

Private Sub ComboBox2_Change()

Worksheets("Sheet1").Range("B5:F112").Value = ""

Worksheets("Sheet2").Cells(1, 12).Value = ComboBox1.Value

Worksheets("Sheet2").Cells(2, 12).Value = ComboBox2.Value

Worksheets("Sheet2").Cells(1, 12).Value = ComboBox1.Value

Worksheets("Sheet2").Cells(2, 12).Value = ComboBox2.Value

Worksheets("Sheet2").Range("B5:F112").SpecialCells(xlCellTypeVisible).COPY

    Sheets("Sheet1").Select

    Range("B5").Select

    'lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row

   ' Range("A" & lMaxRows + 1).Select

    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _

    False, Transpose:=False

    TextBox1.Value = Worksheets("Sheet1").Cells(2, 6).Value

    TextBox1.Value = Format(TextBox1.Value, "Rp #,##0")

    Sheets("Sheet2").Select

ListBox1.ColumnCount = 6

ListBox1.ColumnWidths = 19 & ";" & 60 & ";" & 80 & ";" & 15 & ";" & 40 & ";" & 50

ListBox1.RowSource = "data1"

End Sub

Private Sub UserForm_Initialize()

ComboBox1.List = Sheets("Sheet2").Range("B5:B50").Value

ComboBox2.List = Sheets("Sheet2").Range("B5:B50").Value

End Sub

 Unduh file contoh xlsm >>>>> Filter Tenggang Waktu

Demikian silahkan dikembangkan semoga bermanfaat !!

MENAMPILAKN JUMLAH NOMINAL DENGAN FILTER TANGGAL AWAL SAMPAI TANGGAL AKHIR MULTY KRETERIA - BELAJAR EXCEL VBA

PASTEKAN PADA ComboBox1

Private Sub ComboBox1_Change()

Call FILTER_FOR_TODATE

 [C4].Formula = "=SUM(C6:C100)"

[D4].Formula = "=SUM(D6:D100)"

[E4].Formula = "=SUM(E6:E100)"

If ComboBox1.Value = Range("C5").Value Then

TextBox3.Value = Range("C4").Value

ElseIf ComboBox1.Value = Range("D5").Value Then

TextBox3.Value = Range("D4").Value

ElseIf ComboBox1.Value = Range("E5").Value Then

TextBox3.Value = Range("E4").Value

End If

End Sub

Private Sub TextBox1_Change()

Range("B3").Value = TextBox1.Value

End Sub

Private Sub TextBox2_Change()

Range("B4").Value = TextBox2.Value

End Sub

Private Sub UserForm_Initialize()

ComboBox1.List = Application.Transpose(ActiveSheet.Range("C5:E5").Value)

 TextBox1.Value = Range("B3").Value

 TextBox2.Value = Range("B4").Value

End Sub

PASTEKAN PADA MODUL

Sub FILTER_FOR_TODATE()

ActiveSheet.Range("A6:h200").Value = ""

Sheets("data").Range("A7:E200").Copy

ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues

Dim row As Long

LastRow = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).row

row = 6

For row = LastRow To row Step -1

If Cells(row, 2).Value < Cells(3, 2).Value Then Cells(row, 2).EntireRow.Delete

If Cells(row, 2).Value > Cells(4, 2).Value Then Cells(row, 2).EntireRow.Delete

Next row

End Sub

UNDUH CONTOH FILE >>>  DISINI

FILTER SORT DARI KECIL KE BESAR DAN SEBALIKNYA - KODE VBA

Sub kecil_besar()
[B3:B11].Copy Sheet1.[C3]
ActiveSheet.Range("C2:C11").Sort _
Key1:=Range("C2"), Order1:=xlAscending, Header:=xlYes
End Sub


Sub besar_kecil()
[B3:B11].Copy Sheet1.[D3]
ActiveSheet.Range("D2:D11").Sort _
Key1:=Range("D2"), Order1:=xlDescending, Header:=xlYes
End Sub

REMOVE BLANK CELL AND FILTER LIST DUPLIKAT- EXCEL VBA

Sub RemoveBlankCells()

Dim rng As Range

On Error GoTo NoBlanksFound

  [b2:b20].Copy ActiveSheet.[c2]

    Set rng = Range("c2:c20").SpecialCells(xlCellTypeBlanks)

  On Error GoTo 0

 rng.Rows.Delete Shift:=xlShiftUp

Exit Sub

NoBlanksFound:

  MsgBox "Tidak ada Cell Kosong"

End Sub

Sub buat_list_hapus_duplikat()
Dim x As Range
With CreateObject("scripting.dictionary")
 For Each x In [b3:b20]
  .Item(x.Value) = ""
Next x
[c3].Resize(.Count) = Application.Transpose(.keys)
End With

Dim rng As Range

On Error GoTo NoBlanksFound

    Set rng = Range("c3:c20").SpecialCells(xlCellTypeBlanks)

  On Error GoTo 0

 rng.Rows.Delete Shift:=xlShiftUp

Exit Sub

NoBlanksFound:

  MsgBox "Tidak ada Cell Kosong"
End Sub

'Pastekan Kode Pada Worksheet

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'Hapus Duplicate

[D2].Formula = "=B2"

 [D3:D100].Formula = "=IF(COUNTIF(B2:B3,B3)=2,0,IF(COUNTIF(B3:B3,B3)=1,B3,0))"

'No Urut berdasarkan data D

[C2:C30].Formula = "=IF(C2<>0,COUNTA($C$2:C2),0)"

End Sub

Demikian silahkan dikembangkan lagi 
dan Semoga bermanfaat !!!

dapatkan Aplikasi - aplikasi Gratis pada link dibawah ini
  
Link Konten Blog

Cara Mudah Menentukan Ranking Kelas di Microsoft Excel

Cara Mudah Menentukan Ranking Kelas di Microsoft Excel

Jumlah Nilai "=SUM(C4:G4)

Nilai Rata Rata =IFERROR(AVERAGE(C4:G4),"")

Urutan Nama "=IFERROR(INDEX($B$4:$I$45, MATCH(L4,$J$4:$J$45,0),MATCH($M$3,$B$3:$I$3,0)),"")

Urutan Rata Rata =IFERROR(INDEX($B$4:$I$45, MATCH(L4,$J$4:$J$45,0), MATCH($N$3,$B$3:$I$3,0)),"") UNDUH SAMPEL FILE XLSM >>>> DISINI