Save Purposes (Filter Macro)

Question

Sub Highlight_Duplicate_Rounded()

    Dim ws As Worksheet
    Dim rng As Range, r As Range
    Dim dict As Object
    Dim amtCol As String
    Dim val As Double, key As Double
    
    Set ws = ActiveSheet
    amtCol = "Z"   ' boleh ubah kemudian
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "Sila select rows dahulu.", vbExclamation
        Exit Sub
    End If
    
    Set rng = Selection.Rows
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' STEP 1 — Count rounded values
    For Each r In rng
        
        val = ws.Cells(r.Row, amtCol).Value
        
        If IsNumeric(val) Then
            
            ' Round to 1 decimal
            key = WorksheetFunction.Round(val, 1)
            
            If dict.exists(key) Then
                dict(key) = dict(key) + 1
            Else
                dict.Add key, 1
            End If
            
        End If
        
    Next r
    
    ' STEP 2 — Highlight duplicates
    For Each r In rng
        
        val = ws.Cells(r.Row, amtCol).Value
        
        If IsNumeric(val) Then
            
            key = WorksheetFunction.Round(val, 1)
            
            If dict(key) > 1 Then
                ws.Rows(r.Row).Interior.Color = RGB(189, 215, 238) ' light blue
            End If
            
        End If
        
    Next r
    
    MsgBox "Siap! Duplicate amount (rounded 1 decimal) telah dihighlight.", vbInformation

End Sub

Sub Split_Selected_Inbox()

    Dim ws As Worksheet
    Dim rng As Range, r As Range
    Dim inboxCol As String, amtCol As String
    Dim inboxText As String, inboxKey As String
    Dim targetWs As Worksheet
    Dim highWs As Worksheet
    Dim nextRow As Long
    Dim amt As Double
    
    Set ws = ActiveSheet
    
    inboxCol = "A"
    amtCol = "AA"
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "Sila select rows dahulu.", vbExclamation
        Exit Sub
    End If
    
    Set rng = Selection.Rows
    
    On Error Resume Next
    Set highWs = Worksheets("High Value")
    On Error GoTo 0
    
    If highWs Is Nothing Then
        Set highWs = Worksheets.Add
        highWs.Name = "High Value"
        ws.Rows(1).Copy highWs.Rows(1)
    End If
    
    For Each r In rng
        
        inboxText = Trim(ws.Cells(r.Row, inboxCol).Value)
        inboxKey = UCase(Left(inboxText, 1))
        
        Dim sheetName As String
        
        Select Case inboxKey
            Case "A": sheetName = "011"
            Case "B": sheetName = "030"
            Case "C": sheetName = "005"
            Case "D": sheetName = "090"
            Case "E": sheetName = "015"
            Case "F": sheetName = "SUS"
            Case Else: sheetName = ""
        End Select
        
        If sheetName <> "" Then
            
            On Error Resume Next
            Set targetWs = Worksheets(sheetName)
            On Error GoTo 0
            
            If targetWs Is Nothing Then
                Set targetWs = Worksheets.Add
                targetWs.Name = sheetName
                ws.Rows(1).Copy targetWs.Rows(1)
            End If
            
            nextRow = targetWs.Cells(targetWs.Rows.Count, 1).End(xlUp).Row + 1
            ws.Rows(r.Row).Copy targetWs.Rows(nextRow)
            
        End If
        
        amt = Val(ws.Cells(r.Row, amtCol).Value)
        
        If amt > 1000000 Then
            nextRow = highWs.Cells(highWs.Rows.Count, 1).End(xlUp).Row + 1
            ws.Rows(r.Row).Copy highWs.Rows(nextRow)
        End If
        
        Set targetWs = Nothing
        
    Next r
    
    MsgBox "Siap! Data telah dipecahkan ikut Inbox.", vbInformation

End Sub

Sub TLM_Sort_3Sections()

    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim inboxCol As String, statusCol As String
    Dim keepList As Variant
    Dim splitPending As Long, splitNonKeep As Long
    
    Set ws = ActiveSheet
    
    inboxCol = "A"
    statusCol = "B"
    
    keepList = Array("A", "B", "C", "D", "E", "F", "G", "H", "HSS OVERSEAS INCOME")
    
    lastRow = ws.Cells(ws.Rows.Count, inboxCol).End(xlUp).Row
    
    ' Replace blank inbox
    For i = 2 To lastRow
        If Trim(ws.Cells(i, inboxCol).Value) = "" Then
            ws.Cells(i, inboxCol).Value = "HSS OVERSEAS INCOME"
        End If
    Next i
    
    ' Sort by Status
    ws.Range("A1").CurrentRegion.Sort Key1:=ws.Range(statusCol & "1"), Order1:=xlAscending, Header:=xlYes
    
    ' Find Pending start
    splitPending = lastRow + 1
    
    For i = 2 To lastRow
        If LCase(ws.Cells(i, statusCol).Value) = "pending" Then
            splitPending = i
            Exit For
        End If
    Next i
    
    ' Insert separator + color pending
    If splitPending <= lastRow Then
        
        ws.Rows(splitPending & ":" & splitPending + 2).Insert
        ws.Rows(splitPending & ":" & splitPending + 2).Interior.Color = RGB(0, 0, 0)
        
        For i = splitPending + 3 To lastRow + 3
            ws.Rows(i).Interior.Color = RGB(255, 199, 206)
        Next i
        
        lastRow = lastRow + 3
    End If
    
    ' Sort Outstanding by Inbox
    ws.Range("A1").CurrentRegion.Sort Key1:=ws.Range(inboxCol & "1"), Order1:=xlAscending, Header:=xlYes
    
    ' Find Non Keep start
    splitNonKeep = lastRow + 1
    
    For i = 2 To lastRow
        If IsError(Application.Match(ws.Cells(i, inboxCol).Value, keepList, 0)) _
        And LCase(ws.Cells(i, statusCol).Value) <> "pending" Then
            
            splitNonKeep = i
            Exit For
        End If
    Next i
    
    ' Insert separator
    If splitNonKeep <= lastRow Then
        ws.Rows(splitNonKeep & ":" & splitNonKeep + 2).Insert
        ws.Rows(splitNonKeep & ":" & splitNonKeep + 2).Interior.Color = RGB(0, 0, 0)
    End If
    
    MsgBox "Siap! Data telah disusun kepada 3 bahagian.", vbInformation

End Sub

Answer 1

The provided VBA macros perform various operations in Excel, such as highlighting duplicates, splitting data based on specific criteria, and sorting data into sections. Here’s a brief overview of each macro:

1. Highlight_Duplicate_Rounded: This macro highlights rows in the active worksheet where the rounded values in a specified column (Z) are duplicates. It uses a dictionary to count occurrences of rounded values and colors the rows with duplicates in light blue.
2. Split_Selected_Inbox: This macro splits selected rows into different worksheets based on the first letter of the text in column A (inbox). It also moves rows with amounts greater than 1,000,000 to a "High Value" worksheet.
3. TLM_Sort_3Sections: This macro sorts data into three sections based on the status in column B and the inbox in column A. It replaces blank entries in the inbox with a default value, sorts the data, and inserts separators for pending and non-keep items, coloring them for clarity.

These macros can be useful for organizing and analyzing data in Excel efficiently.