Location via proxy:   [ UP ]  
[Report a bug]   [Manage cookies]                
Scribd
Upload
7 views

FunctionPareto

This VBA script filters data from the 'RINCI RUSAK' worksheet based on a specified value and outputs the results to a designated worksheet. It aggregates quantities and gross values, sorts the data by gross value, and formats the output with borders and auto-incremented row numbers. A confirmation message is displayed upon successful completion of the process.

Uploaded by

kakao.talk.12tk
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
7 views

FunctionPareto

This VBA script filters data from the 'RINCI RUSAK' worksheet based on a specified value and outputs the results to a designated worksheet. It aggregates quantities and gross values, sorts the data by gross value, and formats the output with borders and auto-incremented row numbers. A confirmation message is displayed upon successful completion of the process.

Uploaded by

kakao.talk.12tk
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 2

Attribute VB_Name = "FunctionPareto"

Sub FilterDataToParetoManual(filterValue As String, sheetsView As String)


Dim wsSrc As Worksheet, wsDst As Worksheet
Dim lastRow As Long, dstRow As Long
Dim dict As Object
Dim key As Variant
Dim i As Long
Dim tempArray As Variant
Dim lastCol As Long, newCol As Long
Dim tableRange As Range

' Set worksheet sumber dan tujuan


Set wsSrc = ThisWorkbook.Sheets("RINCI RUSAK")
Set wsDst = ThisWorkbook.Sheets(sheetsView) ' Sheet aktif di mana data akan
ditampilkan

' Hapus data lama di sheet tujuan (tetap mempertahankan format di luar area
yang dihapus)
wsDst.Range("A7:H100").ClearContents

' Cek baris terakhir di sumber data


lastRow = wsSrc.Cells(wsSrc.Rows.Count, 1).End(xlUp).Row

' Inisialisasi dictionary untuk pengelompokan data


Set dict = CreateObject("Scripting.Dictionary")

' Loop melalui data di sheet sumber


For i = 7 To lastRow
If wsSrc.Cells(i, 13).Value = filterValue Then ' Cek kolom "KET RUSAK"
(kolom 13)
key = wsSrc.Cells(i, 9).Value & "|" & wsSrc.Cells(i, 10).Value & "|" &
wsSrc.Cells(i, 15).Value & "|" & _
wsSrc.Cells(i, 7).Value & "|" & wsSrc.Cells(i, 8).Value

If Not dict.exists(key) Then


dict.Add key, Array(wsSrc.Cells(i, 9).Value, wsSrc.Cells(i,
10).Value, wsSrc.Cells(i, 15).Value, _
wsSrc.Cells(i, 7).Value, wsSrc.Cells(i,
8).Value, 0, 0)
End If

' Update SUM(QTY) dan SUM(GROSS)


tempArray = dict(key)
tempArray(5) = tempArray(5) + wsSrc.Cells(i, 11).Value ' SUM(QTY)
tempArray(6) = tempArray(6) + wsSrc.Cells(i, 12).Value ' SUM(GROSS)
dict(key) = tempArray
End If
Next i

' Output hasil ke sheet tujuan


dstRow = 7
For Each key In dict.keys
wsDst.Range("B" & dstRow & ":H" & dstRow).Value = dict(key)
dstRow = dstRow + 1
Next key

' Sortir data berdasarkan GROSS (kolom H) dari terbesar ke terkecil


With wsDst
.Range("A7:H" & dstRow - 1).Sort Key1:=.Range("H7"), Order1:=xlDescending,
Header:=xlNo
End With

' Tambahkan nomor auto increment setelah sortir


For i = 7 To dstRow - 1
wsDst.Cells(i, 1).Value = i - 6
Next i

' Cek kolom terakhir yang digunakan


lastCol = wsDst.Cells(6, wsDst.Columns.Count).End(xlToLeft).Column
newCol = wsDst.Cells(7, wsDst.Columns.Count).End(xlToLeft).Column

' Jika data baru melebihi kolom sebelumnya, salin format ke kolom baru
If newCol > lastCol Then
Dim colDiff As Long
colDiff = newCol - lastCol
For i = 1 To colDiff
wsDst.Columns(lastCol + i).Interior.Color =
wsDst.Columns(lastCol).Interior.Color
wsDst.Columns(lastCol + i).Font.Name = wsDst.Columns(lastCol).Font.Name
wsDst.Columns(lastCol + i).Font.Size = wsDst.Columns(lastCol).Font.Size
Next i
End If

' Terapkan border untuk tabel


Set tableRange = wsDst.Range("A7:H" & dstRow - 1)
With tableRange.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0)
End With

' Pesan konfirmasi


MsgBox "Data berhasil difilter, diformat, dan ditampilkan di sheet " &
sheetsView & ".", vbInformation
End Sub

You might also like