chosen
New Member
- Joined
- Oct 3, 2022
- Messages
- 16
- Office Version
- 2021
- Platform
- Windows
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
Is there a solution to make the macro insert 1000 installments in less than 30 minutes?
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
VBA Code:
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 SubIs there a solution to make the macro insert 1000 installments in less than 30 minutes?
