VBA: Speed up macro (for large file)

[chosen]

Disables screen updating and calculation for faster execution.
Sets references to the first and second worksheets in the workbook.
Sets a reference to the currently selected range in the second worksheet.
Loops through each payment in the selected range and finds the corresponding name in the first worksheet.
If the name is found, it distributes the payments to premiums in the first worksheet until the remaining payment is zero or all premiums have been updated.
If the name is not found, it highlights the payment cell in red.
Enables screen updating again once the macro has finished

But the problem is that the macro inserts 500 installments in more than an hour
And I need to enter more than a thousand installments up to 9000 installments

This is the macro

Sub DistributeInstallments()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim nameColumn As Range, premiumColumn As Range
    Dim paymentColumn As Range
    Dim nameCell As Range, paymentCell As Range
    Dim totalInstallments As Double
    Dim currentName As String
    Dim remainingPayment As Double
    Dim amountToApply As Double
    Dim premium As Double
    
    ' Disable screen updating and calculation for faster execution
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Set references to the first and second sheets
    Set ws1 = ThisWorkbook.Sheets("Sheet1") ' Update "Sheet1" with the name of your first sheet
    Set ws2 = ThisWorkbook.Sheets("Sheet2") ' Update "Sheet2" with the name of your second sheet
    
    ' Set reference to the currently selected range in the second sheet
    Set paymentColumn = Selection
    
    ' Loop through each payment in the selected range
    For Each paymentCell In paymentColumn
        ' Get the corresponding name in the first sheet
        currentName = paymentCell.Value
        
        ' Find the corresponding name in the name column of the first sheet
        Set nameCell = ws1.Columns("Q:Q").Find(What:=currentName, LookIn:=xlValues, LookAt:=xlWhole)
        
        ' If the name is found, distribute the payments to premiums in the first sheet
        If Not nameCell Is Nothing Then
            ' Get the total installments for the current name
            totalInstallments = WorksheetFunction.SumIf(ws1.Range("Q:Q"), currentName, ws1.Range("R:R"))
            
            ' Get the remaining payment from the abbreviation
            remainingPayment = paymentCell.Offset(0, 1).Value
            
            ' Distribute the remaining payment to premiums in the first sheet
            Do While remainingPayment > 0
                ' Get the next premium for the current name
                premium = ws1.Cells(nameCell.Row, "R").Value
                
                ' Check if premium in column AE is less than premium in column R
                If ws1.Cells(nameCell.Row, "AE").Value < premium Then
                    premium = ws1.Cells(nameCell.Row, "AE").Value
                End If
                
                ' Calculate the amount to be applied to the current premium
                amountToApply = WorksheetFunction.Min(premium, remainingPayment)
                
                ' Subtract the amount applied from the remaining payment
                remainingPayment = remainingPayment - amountToApply
                
                ' Update the premium in the first sheet
                ws1.Cells(nameCell.Row, "AC").Value = ws1.Cells(nameCell.Row, "AC").Value + amountToApply
                
                ' Move to the next row in the first sheet
                Set nameCell = ws1.Columns("Q:Q").FindNext(nameCell)
                
                ' Exit the loop if all premiums have been updated
                If nameCell Is Nothing Then Exit Do
            Loop
        Else
            ' Highlight the name not found in red
            paymentCell.Interior.Color = RGB(255, 0, 0) ' Red color
        End If
    Next paymentCell
    
    ' Re-enable screen updating and calculation
    Application.ScreenUpdating = True
End Sub

Is there a solution to make the macro insert 1000 installments in less than 30 minutes?

 

[chosen]

Hi chosen.
I have several annotations, I hope you can read everything:

1) In your seetings you have that you use version 2021 but you shared a version 2003 file. Therefore I have to make a few small adjustments to my macro.​

2) I took the opportunity to adjust my macro, start in row 3 and finish before the row of totals that you have in row 32599 (But the macro gets it dynamically).​

3) I did some tests with your file with a selection of 30 items, I couldn't do tests with more records because Excel crashes.​

4) I did a test with my (updated) code with the same 30. I compared the results of your macro against the results of my macro and they are identical.​

5) In fact I carried out the execution of my macro, selecting all the items and the process took a second.​

IMPORTANT:

1) The logic of your macro has a problem. If the column "AE" value is 0 (or less than 0), the macro enters an endless loop, since when​

remaining Payment subtracts 0, so the remaining Payment never decreases.​

2) If I am correct, if column AE has 0 or less than 0, it means that there is no remaining payment, therefore you should not process that record.​

Please try the following macro with all the records.
I currently put in the range "E8:E507". But you can extend it for all your data in this line:

Set paymentColumn = ws2.Range("E8:E507")

Full macro.

Sub DistributeInstallments_v1()
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim a As Variant, b As Variant, c As Variant, d As Variant, ky As Variant
  Dim dic As Object
  Dim i As Long, j As Long, y As Long
  Dim nRow As Long, nCol As Long, filA As Long, ini As Long, col As Long, lr As Long
  Dim rng As Range, paymentColumn As Range
  Dim kys As String
  Dim remainingPayment As Double, amountToApply As Double, premium As Double
 
  Set ws1 = ThisWorkbook.Sheets("Sheet1") ' Update "Sheet1" with the name of your first sheet
  Set ws2 = ThisWorkbook.Sheets("Sheet2") ' Update "Sheet2" with the name of your second sheet
  Set dic = CreateObject("Scripting.Dictionary")
  Set rng = ws2.Range("A1")
 
  lr = ws1.Range("Q" & Rows.Count).End(3).Row - 4
  a = ws1.Range("A3:AE" & lr).Value                            'sheet1
  ReDim b(1 To UBound(a, 1), 1 To 100)                         'store rows
 
  'Set paymentColumn = Selection                               'selection
  Set paymentColumn = ws2.Range("E8:E507")                               'selection
  Set paymentColumn = paymentColumn.Resize(paymentColumn.Rows.Count, 2)
  c = paymentColumn.Value
  ini = paymentColumn.Cells(1).Row - 1
  col = paymentColumn.Cells(1).Column
  d = Application.Index(a, , 29)                                        'output
 
  For i = 1 To UBound(a, 1)
    kys = a(i, 17)
    If kys <> "" Then
      If Not dic.exists(kys) Then
        y = y + 1
        b(y, 1) = i
        dic(kys) = y & "|" & 1
      Else
        nRow = Split(dic(kys), "|")(0)
        nCol = Split(dic(kys), "|")(1)
        nCol = nCol + 1
        b(nRow, nCol) = i
        dic(kys) = nRow & "|" & nCol
      End If
    End If
  Next
 
  For i = 1 To UBound(c, 1)               'for each item in selection
    kys = c(i, 1)
    If dic.exists(kys) Then
      remainingPayment = c(i, 2)
      j = 1
      nRow = Split(dic(kys), "|")(0)
      nCol = Split(dic(kys), "|")(1)
 
      Do While remainingPayment > 0
        filA = b(nRow, j)
    
        premium = a(filA, 18)               '"R"
        If a(filA, 31) < premium Then
          premium = a(filA, 31)             '"AE"
        End If
        If premium < remainingPayment Then
          amountToApply = premium
        Else
          amountToApply = remainingPayment
        End If
        remainingPayment = remainingPayment - amountToApply
        d(filA, 1) = d(filA, 1) + amountToApply   '"AC"
        j = j + 1
        If j > nCol Then
          If remainingPayment = c(i, 2) Then
            d(filA, 1) = 0
            Exit Do
          End If
          j = 1
        End If
      Loop
    Else
      Set rng = Union(rng, ws2.Cells(i + ini, col))
    End If
  Next
  ws1.Range("AC3").Resize(UBound(d)).Value = d    'Output
  rng.Interior.Color = RGB(255, 0, 0)             'Highlight
  ws2.Range("A1").Interior.Color = xlNone
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------

1- Yes, I am already using the 2021 version, and I do not know how to thank the 2003 file. All I did was save it in xlsb format so that it could be saved with a macro


2- Yes, it is true



3- The same problem, but if you wait for an hour or two, the work will be completed



4- Yes, the same work, but he does not color the installment he puts in red, just like the first one


5- Very cool, thank you very much

 

[DanteAmor]

4- Yes, the same work, but he does not color the installment he puts in red, just like the first one

According to your macro it should only turn the items not found in red and my macro does it correctly. I intentionally changed a couple of names to check it and it does it fine:

According to my tests with your file that you shared the result is correct, check some individual results and others where the name is repeated several times like the ones in the image below and the result is correct:

If one or several results are not correct, you must specify which ones are not correct, which result is set by the macro, and which result is correct.
Please share your test file again.
In this way we will work together to find a suitable solution for you.

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------