Share via

Convert_Amount_Sign_By_CRDR

Sunday WorkTV 10 Reputation points
2025-09-30T03:39:26.5933333+00:00

Hi, can you check my coding below, is there any way to make it shorter, or if there is better coding style i could use, please let me know. This macro used to convert amount into negative and positive value. Thank You. 

Sub ConvertAmountByEventType_Simple()

    Dim ws As Worksheet

    Dim colAmount As String, colType As String

    Dim lastRow As Long, i As Long

    Dim amountCell As Range, typeCell As Range

    Dim typeText As String

    

    Set ws = ActiveSheet

    colAmount = InputBox("Enter the column letter for Amount (e.g. D):", "Amount Column")

    If colAmount = "" Then Exit Sub

    

    colType = InputBox("Enter the column letter for Item Type (CR/DR):", "Item Type Column")

    If colType = "" Then Exit Sub

    lastRow = ws.Cells(ws.Rows.Count, colAmount).End(xlUp).Row

    For i = 1 To lastRow

        Set amountCell = ws.Cells(i, colAmount)

        Set typeCell = ws.Cells(i, colType)

        

        If IsNumeric(amountCell.Value) And amountCell.Value <> "" Then

            typeText = UCase(typeCell.Value)

            

            If InStr(typeText, "CR") > 0 Then

                amountCell.Value = Abs(amountCell.Value) ' Positive

            ElseIf InStr(typeText, "DR") > 0 Then

                amountCell.Value = -Abs(amountCell.Value) ' Negative

            End If

        End If

    Next i

End Sub
Microsoft 365 and Office | Development | Other

Answer accepted by question author

  1. Anonymous
    2025-09-30T04:18:41.3666667+00:00

    Dear @Sunday WorkTV,

    Welcome to Microsoft Q&A Forum! 

    Thank you for your request regarding the macro to convert amounts based on item type. I’ve reviewed and tried my best to research and refine the code to improve its clarity, efficiency, and maintainability. Below is the updated version, followed by a brief explanation of the changes, you can consider consulting it to see if it can help you: 

    Sub ConvertAmountByEventType_Simple()
    Dim ws As Worksheet
    Dim colAmount As String, colType As String
    Dim lastRow As Long, i As Long
    Dim typeText As String
    Set ws = ActiveSheet
    colAmount = InputBox("Enter the column letter for Amount (e.g. D):", "Amount Column")
    If colAmount = "" Then Exit Sub
    colType = InputBox("Enter the column letter for Item Type (CR/DR):", "Item Type Column")
    If colType = "" Then Exit Sub
    lastRow = ws.Cells(ws.Rows.Count, colAmount).End(xlUp).Row
    For i = 1 To lastRow
        With ws
            If IsNumeric(.Cells(i, colAmount).Value) And .Cells(i, colAmount).Value <> "" Then
                typeText = UCase(.Cells(i, colType).Value)
                Select Case True
                    Case InStr(typeText, "CR") > 0
                        .Cells(i, colAmount).Value = Abs(.Cells(i, colAmount).Value)
                    Case InStr(typeText, "DR") > 0
                        .Cells(i, colAmount).Value = -Abs(.Cells(i, colAmount).Value)
                End Select
            End If
        End With
    Next i
End Sub

    Here are the points in my codes: 

    1.I simplified cell access: removed the use of separate Range variables (amountCell, typeCell) and accessed cells directly using .Cells(i, colAmount) and .Cells(i, colType) for cleaner code. 

    2.I used with ws block: this reduces repetition of ws. and improves readability by grouping all worksheet-related operations. 

    3.I replaced If...else If with select case: this makes the logic easier to follow and more scalable if additional conditions are needed in the future. 

    4.I preserved original functionality: the macro still converts "CR" amounts to positive and "DR" amounts to negative, based on the item type column. 

    Besides that, the macro has been updated by consulting ideas in these documents from Microsoft. For reference, here are official documentation links that explain the key VBA concepts used in the code, you can take a look as well: 

    As a Microsoft Q&A moderator, my role is to guide discussions and connect users with helpful resources. While I don’t have the right to access to your individual account or your environment in order to help you further. However, I still try my best to support you using the resources available. So, please kindly try my suggestion above. 

    I hope this information can help you in your case. Wish you a pleasant day! 

    If the answer is helpful, please click "Accept Answer" and kindly upvote it. If you have extra questions about this answer, please click "Comment". 

    Note: Please follow the steps in our documentation to enable e-mail notifications if you want to receive the related email notification for this thread. 

    User's image

    2 people found this answer helpful.

1 additional answer

Sort by: Most helpful
Most helpful Newest Oldest
  1. Sunday WorkTV 10 Reputation points
    2025-10-01T14:05:47.3966667+00:00 
    Option Explicit

' -------------------------
' Helpers: safe number/date
' -------------------------
Private Function SafeDouble(v As Variant) As Double
    If IsError(v) Then
        SafeDouble = 0
    ElseIf IsNumeric(v) Then
        SafeDouble = CDbl(v)
    Else
        SafeDouble = 0
    End If
End Function

Private Function SafeDateText(v As Variant) As String
    On Error Resume Next
    If IsDate(v) Then
        SafeDateText = Format(CDate(v), "dd/mm/yyyy")
    Else
        SafeDateText = Trim(CStr(v))
    End If
    On Error GoTo 0
End Function

' -------------------------
' Normalize ISIN (first match of 2 letters + 10 alnum)
' -------------------------
Private Function NormalizeISIN(txt As String) As String
    Dim re As Object, m As Object
    Dim s As String
    s = UCase(Trim(CStr(txt)))
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "([A-Z]{2}[A-Z0-9]{10})"
    re.Global = False
    re.IgnoreCase = True
    If re.Test(s) Then
        Set m = re.Execute(s)
        NormalizeISIN = m(0).SubMatches(0)
    Else
        NormalizeISIN = ""
    End If
End Function

' -------------------------
' Normalize EventID (first 10-digit sequence)
' -------------------------
Private Function NormalizeEventID(txt As String) As String
    Dim re As Object, m As Object
    Dim s As String
    s = Trim(CStr(txt))
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d{10})"
    re.Global = False
    re.IgnoreCase = True
    If re.Test(s) Then
        Set m = re.Execute(s)
        NormalizeEventID = m(0).SubMatches(0)
    Else
        NormalizeEventID = ""
    End If
End Function

' -------------------------
' Exclude pattern test for Ref2 (e.g. 28AD/MSA, 28E/IC etc.)
' Pattern: starts with 28 then 1-2 chars then "/" then 2-4 chars
' -------------------------
Private Function IsRef2Excluded(txt As String) As Boolean
    Dim re As Object
    Dim s As String
    s = Trim(CStr(txt))
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^28[A-Z0-9]{1,2}/[A-Z0-9]{2,4}"
    re.IgnoreCase = True
    IsRef2Excluded = re.Test(s)
End Function

' -------------------------
' Colour helper
' -------------------------
Private Sub ColorRowIfNotGreen(ws As Worksheet, r As Long, clr As Long)
    If ws.Rows(r).Interior.Color <> vbGreen Then
        ws.Rows(r).Interior.Color = clr
    End If
End Sub

' -------------------------
' MAIN: group-based with connectivity (transitive) and normalized ISIN cross-match
' -------------------------
Sub Reconcile_Grouped_Connectivity()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")   ' <<< Ganti nama sheet jika perlu
    
    ' -------------------------
    ' COLUMN MAPPING (ubah jika layout berubah)
    ' -------------------------
    ' Match ID = Col B  (2)
    ' CCY      = Col D  (4)
    ' TYPE     = Col E  (5)  ' (not used for logic here)
    ' Amount   = Col F  (6)
    ' ValueDt  = Col G  (7)
    ' Ref1     = Col AB (28)
    ' Ref2     = Col AC (29)
    ' Ref3     = Col AD (30)
    ' Set      = Col AE (31)
    ' -------------------------
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If LastRow < 2 Then
        MsgBox "Tiada data (pastikan Match ID di Column B).", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' clear previous colours (optional)
    ws.Range(ws.Cells(2, 2), ws.Cells(LastRow, 31)).Interior.ColorIndex = xlNone
    
    ' --- Build groups by MatchID + CCY (exclude rows per your rules) ---
    Dim groups As Object: Set groups = CreateObject("Scripting.Dictionary")
    Dim i As Long
    For i = 2 To LastRow
        Dim mid As String, ccy As String, setVal As String, ref2val As String
        mid = Trim(CStr(ws.Cells(i, 2).Value))   ' col B
        ccy = Trim(CStr(ws.Cells(i, 4).Value))   ' col D
        setVal = Trim(CStr(ws.Cells(i, 31).Value)) ' col AE
        ref2val = Trim(CStr(ws.Cells(i, 29).Value)) ' col AC
        
        ' Exclusion: Set = "USD-87352-DCM"
        If UCase(setVal) = "USD-87352-DCM" Then
            ' skip - do not include in any group
        ElseIf IsRef2Excluded(ref2val) Then
            ' skip
        Else
            Dim key As String
            key = mid & "|" & ccy
            If Not groups.Exists(key) Then
                groups.Add key, New Collection
            End If
            groups(key).Add i
        End If
    Next i
    
    ' --- Process each group: build adjacency & find connected components ---
    Dim k As Variant
    For Each k In groups.Keys
        Dim colRows As Collection
        Set colRows = groups(k)
        Dim n As Long: n = colRows.Count
        If n <= 1 Then GoTo NextGroup   ' nothing to compare
        
        ' Prepare arrays for quick access
        Dim rows() As Long: ReDim rows(1 To n)
        Dim amt() As Double: ReDim amt(1 To n)
        Dim ref1() As String, ref2() As String, ref3() As String
        Dim nref1() As String, nref2() As String, nev() As String
        Dim valdt() As String
        ReDim ref1(1 To n): ReDim ref2(1 To n): ReDim ref3(1 To n)
        ReDim nref1(1 To n): ReDim nref2(1 To n): ReDim nev(1 To n)
        ReDim valdt(1 To n)
        
        Dim idx As Long
        For idx = 1 To n
            rows(idx) = colRows(idx)
            amt(idx) = SafeDouble(ws.Cells(rows(idx), 6).Value)     ' col F
            ref1(idx) = Trim(CStr(ws.Cells(rows(idx), 28).Value))   ' col AB
            ref2(idx) = Trim(CStr(ws.Cells(rows(idx), 29).Value))   ' col AC
            ref3(idx) = Trim(CStr(ws.Cells(rows(idx), 30).Value))   ' col AD
            nref1(idx) = NormalizeISIN(ref1(idx))
            nref2(idx) = NormalizeISIN(ref2(idx))
            nev(idx) = NormalizeEventID(ref3(idx))
            valdt(idx) = SafeDateText(ws.Cells(rows(idx), 7).Value) ' col G
        Next idx
        
        ' adjacency list: dictionary index -> collection of neighbor indices (1..n)
        Dim adj As Object: Set adj = CreateObject("Scripting.Dictionary")
        For idx = 1 To n
            adj.Add CStr(idx), New Collection
        Next idx
        
        ' build edges using rules (priority order 1,7,3,4,5,6,2)
        Dim p As Long, q As Long
        For p = 1 To n - 1
            For q = p + 1 To n
                Dim ruleMatched As Boolean: ruleMatched = False
                
                ' RULE 1: exact ref1/ref2/ref3 equality
                If ref1(p) <> "" And ref2(p) <> "" And ref3(p) <> "" Then
                    If ref1(p) = ref1(q) And ref2(p) = ref2(q) And ref3(p) = ref3(q) Then
                        ruleMatched = True
                    End If
                End If
                
                ' RULE 7: ref2 (ISIN normalized) + eventID normalized
                If Not ruleMatched Then
                    If nref2(p) <> "" And nref2(p) = nref2(q) And nev(p) <> "" And nev(p) = nev(q) Then
                        ruleMatched = True
                    End If
                End If
                
                ' RULE 3: ref2 equal and is ISIN (raw exact same and looks like ISIN)
                If Not ruleMatched Then
                    If ref2(p) <> "" And ref2(p) = ref2(q) Then
                        If NormalizeISIN(ref2(p)) <> "" Then
                            ruleMatched = True
                        End If
                    End If
                End If
                
                ' RULE 4: ref2 normalized ISIN equal (different formats)
                If Not ruleMatched Then
                    If nref2(p) <> "" And nref2(p) = nref2(q) Then
                        ruleMatched = True
                    End If
                End If
                
                ' RULE 5: cross match ref1 <-> ref2 (ISIN normalized)
                If Not ruleMatched Then
                    If (nref1(p) <> "" And nref1(p) = nref2(q)) Or (nref2(p) <> "" And nref2(p) = nref1(q)) Then
                        ruleMatched = True
                    End If
                End If
                
                ' RULE 6: cross match ref1 <-> ref2 non-ISIN (raw equality)
                If Not ruleMatched Then
                    If (ref1(p) <> "" And ref1(p) = ref2(q) And NormalizeISIN(ref1(p)) = "") _
                      Or (ref2(p) <> "" And ref2(p) = ref1(q) And NormalizeISIN(ref1(q)) = "") Then
                        ruleMatched = True
                    End If
                End If
                
                ' RULE 2: only ref2 same non-ISIN (last)
                If Not ruleMatched Then
                    If ref2(p) <> "" And ref2(p) = ref2(q) And NormalizeISIN(ref2(p)) = "" Then
                        ruleMatched = True
                    End If
                End If
                
                If ruleMatched Then
                    adj(CStr(p)).Add q
                    adj(CStr(q)).Add p
                End If
            Next q
        Next p
        
        ' --- find connected components (BFS/DFS) on adj graph ---
        Dim visited() As Boolean: ReDim visited(1 To n)
        Dim comp As Collection
        For idx = 1 To n
            If Not visited(idx) Then
                ' BFS stack
                Set comp = New Collection
                Dim stack As Collection: Set stack = New Collection
                stack.Add idx
                visited(idx) = True
                Do While stack.Count > 0
                    Dim cur As Long
                    cur = stack(1)
                    stack.Remove 1
                    comp.Add cur
                    ' neighbors
                    Dim nb As Variant
                    For Each nb In adj(CStr(cur))
                        If Not visited(nb) Then
                            visited(nb) = True
                            stack.Add nb
                        End If
                    Next nb
                Loop
                
                ' Only color if component has >1 node (match group)
                If comp.Count > 1 Then
                    ' compute sum and unique dates
                    Dim sumAmt As Double: sumAmt = 0
                    Dim uniqDates As Object: Set uniqDates = CreateObject("Scripting.Dictionary")
                    Dim node As Variant
                    For Each node In comp
                        sumAmt = sumAmt + amt(node)
                        If Not uniqDates.Exists(valdt(node)) Then uniqDates.Add valdt(node), 1
                    Next node
                    
                    ' decide color:
                    If Abs(sumAmt) <= 0.1 Then
                        If uniqDates.Count = 1 Then
                            ' strict green
                            For Each node In comp
                                ws.Rows(rows(node)).Interior.Color = vbGreen
                            Next node
                        Else
                            ' date mismatch -> mark orange (per rule: date must match for green)
                            For Each node In comp
                                ws.Rows(rows(node)).Interior.Color = RGB(255, 165, 0)
                            Next node
                        End If
                    ElseIf Abs(sumAmt) <= 1 Then
                        ' near tolerance -> orange
                        For Each node In comp
                            ws.Rows(rows(node)).Interior.Color = RGB(255, 165, 0)
                        Next node
                    Else
                        ' not matched -> no color
                    End If
                End If
            End If
        Next idx
        
NextGroup:
        ' next group
    Next k
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "Matching complete (group connectivity).", vbInformation
End Sub

Your answer

Answers can be marked as 'Accepted' by the question author and 'Recommended' by moderators, which helps users know the answer solved the author's problem.