I have a piece of code that loops over a range, and checks if the cell above matches the current cell.
When it finds a different cell above the current, insert a row, and add the street name to column "A", then continue.
The problem I am having is it take a while for it to process, can you suggest a different method.
Here is the code I am currently using.
headingRange = wb.SCAA.cells(Rows.count, lastCol + 2).End(xlUp).Row
For headingID = headingRange To 7 Step -1
lookupval = wb.SCAA.cells(headingID, lastCol + 2)
With cells(headingID, lastCol + 2)
If lookupval <> .Offset(-1) Then
.EntireRow.Insert , CopyOrigin:=xlFormatFromRightOrBelow
With cells(headingID, 1)
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.ShrinkToFit = False
.ReadingOrder = xlContext
.Font.bold = True
.Font.Underline = xlUnderlineStyleSingle
.IndentLevel = 0
End With
cells(headingID, 1) = wb.SCAA.cells(headingID + 1, lastCol + 2)
End If
End With
Next headingID
Here is an example screen shot of the data that I am trying to process.
This is how the data should look after being grouped.
As Requested, here is the whole sub.
Dim wb As Workbook: Set wb = ThisWorkbook
Dim lastRowWIR, lastRowPH, lastRowCODES, lastRow, lastCol As Long
Dim address, worktypeHeading, worktype_Valuation, headingID, headingRange, i As Long
Dim add_range_PH As Range, wID_range_PH As Range, sum_range_PH, sub_range_PH As Range
Dim add_range As Range, wID_range As Range, sum_range, sub_range As Range
Dim RangeCodes, RangeWIR, RangePH
Dim contract_total As Integer
Dim myRange As Range
Dim accountCode As Object: Set accountCode = CreateObject("Scripting.Dictionary")
Dim CodeList As Object: Set CodeList = CreateObject("Scripting.Dictionary")
Dim addressList As Object: Set addressList = CreateObject("Scripting.Dictionary")
Dim addressAFA As Object: Set addressAFA = CreateObject("Scripting.Dictionary")
Dim addressValuation As Object: Set addressValuation = CreateObject("Scripting.Dictionary")
Dim addressValuationTotal As Object: Set addressValuationTotal = CreateObject("Scripting.Dictionary")
Dim ContractList As Object: Set ContractList = CreateObject("Scripting.Dictionary")
Dim PHElementTotal As Object: Set PHElementTotal = CreateObject("Scripting.Dictionary")
'''' TEST IF THE WORKS INSTRUCTION RECORD AND PAYMENT HISTORY HAVE FILTERS APPLIED, IF TRUE THEN REMOVE THEM
If wb.WIR.FilterMode = True Then wb.WIR.AutoFilter.ShowAllData
If wb.PH.FilterMode = True Then wb.PH.AutoFilter.ShowAllData
'''' CALL THE PROGRESS USERFORM SUBROUTINE
Call UserFrmProgressSub("Currently Producing Statement for: " & wb.SCAA.cells(2, 2).value, False)
'''' DO THE FIRST DEFINE FOR LAST ROWS IN DIFFERENT SHEETS, AND LAST COLUMN
lastCol = wb.SCAA.cells(6, columns.count).End(xlToLeft).Column
lastRowWIR = wb.WIR.cells(Rows.count, WIR_AccountWorktypeID).End(xlUp).Row
lastRowPH = wb.PH.cells(Rows.count, "C").End(xlUp).Row
lastRowCODES = wb.CODES.cells(Rows.count, "F").End(xlUp).Row
'''' SET THE RANGE FOR THE EMAILIST DICTIOANARY CREATION
RangePH = wb.PH.Range("C2:H" & lastRowPH).value
RangeCodes = wb.CODES.Range("F3:G" & lastRowCODES).value
RangeWIR = wb.WIR.Range(wb.WIR.cells(3, WIR_AddressCode), wb.WIR.cells(lastRowWIR, WIR_ULRecharge)).value
'''' CREATE A SCRIPTING DICTIONARY TO HOLD THE ACCOUNT CODES (KEY:C, VALUE:CYCLICAL)
For i = LBound(RangeCodes) To UBound(RangeCodes, 1)
'''' IF THE SUBCONTRACTOR IS NOT IN THE DICTIONARY THEN ADD IT
If Not accountCode.exists(RangeCodes(i, 1)) Then accountCode.add RangeCodes(i, 1), RangeCodes(i, 2)
Next i
'''' CRAEATE MULTIPLE DICTIONARYS FROM THE WORKS INSTRUCTION RECORD
For i = LBound(RangeWIR) To UBound(RangeWIR, WIR_AddressCode)
'''' ONLY ADD ITEMS TO THE RELEVANT DICTONARY IF THE SUBCONTRACTOR MATCHES THE SELECTED
If RangeWIR(i, WIR_SubContractor) = cells(2, 2) Then
'''' PRODUCE A CODE LIST FROM THE WIR BASED ON THE ACCOUNT WORKTYPE ID, THEN GET THE MATCHING VALUE FROM THE ACCONTCODE LIST KEYS FROM WIR, VALUE FROM CODELIST(KEY:L, VALUE:LIFECYLCE)
If Not CodeList.exists(RangeWIR(i, WIR_AccountWorktypeID)) Then CodeList.add RangeWIR(i, WIR_AccountWorktypeID), accountCode(RangeWIR(i, WIR_AccountWorktypeID))
'''' CREATE AND ADDRESS LIST WITH THE ADDRESS AS THE KEY, CONTACT, STREET AND PROPERTY NUMBER MAKE UP THE VALUE
If Not addressList.exists(RangeWIR(i, WIR_AddressCode)) Then addressList.add RangeWIR(i, WIR_AddressCode), RangeWIR(i, WIR_Contract) & "|" & RangeWIR(i, WIR_Street) & "|" & Left(RangeWIR(i, WIR_AddressCode), InStr(RangeWIR(i, WIR_AddressCode), " "))
'''' CREATE A DICTIONARY FOR THE CONTRACTS, EITHER PFI1, PFI2 OR BOTH
If Not ContractList.exists(RangeWIR(i, WIR_Contract)) Then ContractList.add RangeWIR(i, WIR_Contract), RangeWIR(i, WIR_Contract)
'''' DEFINE THE KEYS USED FOR THE ADDRESSAFA DICTONARY ADDRESS AND ACCOUNTWORKTYPE (14 ALMORAH ROAD|CYCLICAL)
key = RangeWIR(i, WIR_AddressCode) & "|" & CodeList(RangeWIR(i, WIR_AccountWorktypeID))
'''' THE ADDRESSAFA IS THE KEY AND THE RML ORDER VALUE FOR THAT ADDRESS AND CODE
If Not addressAFA.exists(key) Then '''' IF THAT KEY IS NOT ALREADY IN THE DICTIONARY THE ADD IT WITH THE VALE
addressAFA.add key, Round(RangeWIR(i, WIR_RMLOrderValue), 2)
Else '''' IF THE KEY IS IN THE DICTIONATY THE ADD THE NEW VALUE WITH WHATS ALREADY IN THE DICTIONARY
addressAFA(key) = addressAFA(key) + Round(RangeWIR(i, WIR_RMLOrderValue), 2)
End If
End If
Next i
'''' CRAEATE MULTIPLE DICTIONARYS FROM THE PAYMENT HISTORY
For i = LBound(RangePH) To UBound(RangePH, 1)
If RangePH(i, 2) = cells(2, 2) Then
key = RangePH(i, 1) & "|" & CodeList(RangePH(i, 3))
'''' TOTAL VALUE FOR ADDRESS & ELEMTENT (CYCLICAL)
If Not addressValuation.exists(key) Then
addressValuation.add key, Round(RangePH(i, 6), 2)
Else
addressValuation(key) = addressValuation(key) + Round(RangePH(i, 6), 2)
End If
'''' TOTAL VALUE FOR ADDRESS
If Not addressValuationTotal.exists(RangePH(i, 1)) Then
addressValuationTotal.add RangePH(i, 1), Round(RangePH(i, 6), 2)
Else
addressValuationTotal(RangePH(i, 1)) = addressValuationTotal(RangePH(i, 1)) + Round(RangePH(i, 6), 2)
End If
'''' PRODUCE A CODE LIST FROM THE WIR BASED ON THE ACCOUNT WORKTYPE ID, THEN GET THE MATCHING VALUE FROM THE ACCONTCODE LIST KEYS FROM WIR, VALUE FROM CODELIST(KEY:L, VALUE:LIFECYLCE)
If Not PHElementTotal.exists(accountCode(RangePH(i, 3))) Then
PHElementTotal.add accountCode(RangePH(i, 3)), Round(RangePH(i, 6), 2)
Else
PHElementTotal(accountCode(RangePH(i, 3))) = PHElementTotal(accountCode(RangePH(i, 3))) + Round(RangePH(i, 6), 2)
End If
If Not PHElementTotal.exists("Total") Then
PHElementTotal.add "Total", Round(RangePH(i, 6), 2)
Else
PHElementTotal("Total") = PHElementTotal("Total") + Round(RangePH(i, 6), 2)
End If
End If
Next i
'''' SET THE ACCOUNTCODE DICTIONATY TO NOTHING TO FREE MEMORY (NOT USED AGAIN IN ROUTINE)
Set accountCode = Nothing
'''' TEST IF THE CODELIST HAS A COUNT OF 0, IF TRUE THE SUBCONTRACTO HAD NO WORK ISSUED TO THEN AND NOTHING PAID TO THEN. EXIT THE SUB
If CodeList.count = "0" Then
MsgBox wb.SCAA.cells(2, 2).value & " has had no works issued to them." & vbLf & "A statement cannot be produced!", vbCritical, "SubContractor Statement Error"
Exit Sub
End If
'''' CLEAR THE SHEET BEFORE STARTING
wb.SCAA.Rows("4:" & wb.SCAA.cells(Rows.count, lastCol).End(xlUp).Row + 10).Clear
'''' CALL THE SUBROUTINE TO CREATE THE SHEET HEADINGS
Call createSCAccountHeadings1(CodeList.count, CodeList)
'''' REDEFINE THE LAST COLUMN AFTER THE HEADINGS HAVE BEEN CREATED
lastCol = wb.SCAA.cells(6, columns.count).End(xlToLeft).Column
'''' LOOP OVER THE ADDRESS LIST, AND SPLIT THE ITEM, TO ADD THE ADDRESS, PFI, PROPERTY NUMBER AND STREET TO SHEET
tableStart = 7
For Each key In addressList.keys
wb.SCAA.cells(tableStart, 1) = key
wb.SCAA.cells(tableStart, 2) = Split(addressList(key), "|")(0)
wb.SCAA.cells(tableStart, lastCol + 2) = Split(addressList(key), "|")(1)
wb.SCAA.cells(tableStart, lastCol + 1) = Split(addressList(key), "|")(2)
tableStart = tableStart + 1
Next key
'''' DEFINE THE LASTROW
lastRow = wb.SCAA.cells(Rows.count, 1).End(xlUp).Row
'''' APPLY INDENTS TO THE ADDRESS'S AND AUTOFIT COLUMN 1
wb.SCAA.Range("A7:A" & lastRow).InsertIndent 2
wb.SCAA.columns(1).AutoFit
'''' SET THE RANGES IN FOR THE SUM IF FUNCTIONS USED.
Set add_range = wb.WIR.columns(WIR_AddressCode)
Set wID_range = wb.WIR.columns(WIR_AccountWorktypeID)
Set sub_range = wb.WIR.columns(WIR_SubContractor)
Set sum_range = wb.WIR.columns(WIR_RMLOrderValue)
Set add_range_PH = wb.PH.Range("C:C")
Set wID_range_PH = wb.PH.Range("E:E")
Set sub_range_PH = wb.PH.Range("D:D")
Set sum_range_PH = wb.PH.Range("H:H")
'''' DEFINE MYRANGE
Set myRange = Range(cells(3, 1), cells(lastRow, lastCol))
'''' LOOP OVER THE ADDRESS AND WORKTYPE(COLUMNS), AND ADD VALUES AND FORMULAS
For address = 7 To lastRow
addressIns = wb.SCAA.cells(address, 1).value
For worktypeHeading = 3 To myRange.columns.count
Set wtHeading = wb.SCAA.cells(6, worktypeHeading)
Select Case True
Case worktypeHeading - 2 <= CodeList.count
If IsEmpty(addressAFA(addressIns & "|" & wtHeading)) Then
wb.SCAA.cells(address, worktypeHeading) = 0
Else
wb.SCAA.cells(address, worktypeHeading) = Format(addressAFA(addressIns & "|" & wtHeading), "Standard")
End If
wb.SCAA.cells(address, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Case worktypeHeading - 2 = CodeList.count + 1
wb.SCAA.cells(address, worktypeHeading).value = Round(Application.WorksheetFunction.Sum(Range(cells(address, 3), cells(address, worktypeHeading - 1))), 2)
wb.SCAA.cells(address, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Case worktypeHeading - 2 = CodeList.count + 2
If cells(address, worktypeHeading - 1) = "0" And (addressValuationTotal(addressIns) = "0" Or IsEmpty(addressValuationTotal(addressIns))) Then
wb.SCAA.cells(address, worktypeHeading).value = "0"
Else
wb.SCAA.cells(address, worktypeHeading).value = addressValuationTotal(addressIns) / cells(address, worktypeHeading - 1)
End If
wb.SCAA.cells(address, worktypeHeading).NumberFormat = "0.00%"
wb.SCAA.cells(address, "AAA").value = wb.SCAA.cells(address, worktypeHeading)
wb.SCAA.columns(worktypeHeading).AutoFit
Case worktypeHeading - 2 > CodeList.count And worktypeHeading - 2 < myRange.columns.count - 2
If IsEmpty(addressValuation(addressIns & "|" & wtHeading)) Then
totalValuation = 0
Else
totalValuation = addressValuation(addressIns & "|" & wtHeading)
End If
myformula = "=Round(IF(" & cells(address, (worktypeHeading - (CodeList.count + 2))).address(False, False) & "=" & totalValuation & "," & totalValuation & "," & "SUM(" & cells(address, (worktypeHeading - (CodeList.count + 2))).address(False, False) & "*" & cells(address, CodeList.count + 4).address(False, False) & ")),2)"
wb.SCAA.cells(address, worktypeHeading).formula = myformula
wb.SCAA.cells(address, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Case worktypeHeading - 2 = myRange.columns.count - 2
wb.SCAA.cells(address, lastCol).formula = "=round(sum(" & cells(address, 5 + CodeList.count).address(False, False) & ":" & cells(address, worktypeHeading - 1).address(False, False) & "),2)"
wb.SCAA.cells(address, lastCol).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
End Select
Next worktypeHeading
Next address
'''' SET THE BELOW SCRIPTING DICTIONARYS TO NOTHING, TO FREE MEMORY
Set addressList = Nothing
Set addressAFA = Nothing
Set addressValuation = Nothing
Set addressValuationTotal = Nothing
'''' REDEFINE THE LAST ROW
lastRow = wb.SCAA.cells(Rows.count, "A").End(xlUp).Row
'''' TRANSPOSE THE CONTRACT LIST ON TO THE SHEET UNDER THE ADDRESS
wb.SCAA.Range("B" & lastRow + 2).Resize(ContractList.count, 1) = WorksheetFunction.Transpose(ContractList.keys)
'''' SORT THE CONTRACT LIST A - Z
If ContractList.count <> 1 Then wb.SCAA.Range("B" & lastRow + 2 & ":B" & lastRow + 2 + (ContractList.count - 1)).Sort Key1:=cells(lastRow + 2, 2), Order1:=xlAscending, Header:=xlNo
'''' DEFINE THE LAST ROW IN COLUMN B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row
'''' ADD "TOTAL" TO THE SHEET
wb.SCAA.cells(lastRowB + 2, 2) = "TOTAL"
'''' LOOP OVER THE CONTRACT LIST AT BOTTOM AND TOTAL, AND ADD FORMULAS THERE APPRIOPRIATE
For contract_total = lastRow + 2 To lastRowB + 2
For worktypeHeading = 3 To myRange.columns.count
Set wtHeading = wb.SCAA.cells(6, worktypeHeading)
If contract_total = lastRowB + 1 Then Exit For
If wtHeading.Offset(-1) <> "PROGRESS" Then
If contract_total <> lastRowB + 2 Then
wb.SCAA.cells(contract_total, worktypeHeading).formula = "=round(sumif(" & cells(7, 2).address & ":" & cells(lastRow, 2).address & "," & cells(contract_total, 2).address & "," & cells(7, worktypeHeading).address & ":" & cells(lastRow, worktypeHeading).address & "),2)"
wb.SCAA.cells(contract_total, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Else
wb.SCAA.cells(lastRowB + 2, worktypeHeading).formula = "=round(Sum(" & cells(lastRowB - 1, worktypeHeading).address & ":" & cells(lastRowB, worktypeHeading).address & "),2)"
wb.SCAA.cells(lastRowB + 2, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
End If
End If
Next worktypeHeading
Next contract_total
'''' RE-DEFINE THE LAST ROW IN COLUMN B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row
'''' ADD TWO HEADINGS
wb.SCAA.cells(lastRowB + 2, 3 + CodeList.count) = "TOTAL ALREADY PAID"
wb.SCAA.cells(lastRowB + 4, 3 + CodeList.count) = "TOTAL CHANGED"
'''' ADD THE FORMULAS TO THE TOTAL ALDREAY PAID, AND TOTAL CHANGED
For worktype_Valuation = CodeList.count + 5 To myRange.columns.count
worktype_value = wb.SCAA.cells(6, worktype_Valuation)
If IsEmpty(PHElementTotal(worktype_value)) Or PHElementTotal(worktype_value) = 0 Then
tempTotal = 0
Else
tempTotal = PHElementTotal(worktype_value)
End If
If worktype_value <> "Total" Then
wb.SCAA.cells(lastRowB + 2, worktype_Valuation) = tempTotal
wb.SCAA.cells(lastRowB + 2, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
wb.SCAA.cells(lastRowB + 4, worktype_Valuation).formula = "=round(sum(" & cells(lastRowB, worktype_Valuation).address & ":" & cells(lastRowB, worktype_Valuation).address & ",-" & cells(lastRowB + 2, worktype_Valuation).address & "),2)"
wb.SCAA.cells(lastRowB + 4, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Else
wb.SCAA.cells(lastRowB + 2, worktype_Valuation) = tempTotal
wb.SCAA.cells(lastRowB + 2, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
wb.SCAA.cells(lastRowB + 4, worktype_Valuation).formula = "=round(sum(" & cells(lastRowB, worktype_Valuation).address & ":" & cells(lastRowB, worktype_Valuation).address & ",-" & cells(lastRowB + 2, worktype_Valuation).address & "),2)"
wb.SCAA.cells(lastRowB + 4, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
End If
Next worktype_Valuation
Set PHElementTotal = Nothing
'''' CALL THE SORTING SUB ROUTINE
Call sortData(wb.SCAA, 7, (lastRow), (lastCol + 2), False, (lastCol + 1))
'''' LOOP OVER THE ROWS, AND SEPERATE THE ADDRESS INTO SREETS
headingRange = wb.SCAA.cells(Rows.count, lastCol + 2).End(xlUp).Row
For headingID = headingRange To 7 Step -1
lookupval = wb.SCAA.cells(headingID, lastCol + 2)
With cells(headingID, lastCol + 2)
If lookupval <> .Offset(-1) Then
.EntireRow.Insert , CopyOrigin:=xlFormatFromRightOrBelow
With cells(headingID, 1)
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.ShrinkToFit = False
.ReadingOrder = xlContext
.Font.bold = True
.Font.Underline = xlUnderlineStyleSingle
.IndentLevel = 0
End With
cells(headingID, 1) = wb.SCAA.cells(headingID + 1, lastCol + 2)
End If
End With
Next headingID
'''' ONCE ADDRESS'S HAVE BEEN SORTED AND ADDRESS'S GROUPED INTO STREETS, CLEAR THE STREET HAS PROPERTY NUMBER IN THE LAST 2 COLUMNS
With Union(columns(lastCol + 1), columns(lastCol + 2))
.ClearContents
End With
'''' REFINE LAST ROW: COLUMN A, AND LAST ROW B: COLUMN B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row
lastRow = wb.SCAA.cells(Rows.count, "A").End(xlUp).Row
'''' APPLY BORDERS TO THE SHEET, AND FORMAT
With wb.SCAA
With Union(Range(cells(7, 1), cells(lastRow, lastCol)), _
Range(cells(lastRowB, 2), cells(lastRowB, CodeList.count + 3)), _
Range(cells(lastRowB, 5 + CodeList.count), cells(lastRowB, lastCol)), _
Range(cells(lastRow + 2, 2), cells(lastRow + 1 + ContractList.count, 2 + CodeList.count + 1)), _
Range(cells(lastRow + 2, 5 + CodeList.count), cells(lastRow + 1 + ContractList.count, lastCol)), _
Range(cells(lastRowB + 2, 5 + CodeList.count), cells(lastRowB + 2, lastCol)), _
Range(cells(lastRowB + 4, 5 + CodeList.count), cells(lastRowB + 4, lastCol)))
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlThin
With Range(cells(7, 2), cells(lastRowB, 2))
.HorizontalAlignment = xlVAlignCenter
.VerticalAlignment = xlVAlignCenter
End With
With Union(Range(cells(7, 1), cells(lastRow, 1)), _
Range(cells(7, 2), cells(lastRow, 2)), _
Range(cells(7, 4 + CodeList.count), cells(lastRow, 4 + CodeList.count)))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlThick
End With
End With
End With
'''' LOOP OVER ALL THE ADDRESS'S AND APPLY CONDITIONAL FORMATTING
lastRow = wb.SCAA.cells(Rows.count, "A").End(xlUp).Row
For address = 7 To lastRow
If IsEmpty(cells(address, 4 + CodeList.count).value) = False Then
With wb.SCAA.Range(wb.SCAA.cells(address, 1), wb.SCAA.cells(address, lastCol))
.FormatConditions.add Type:=xlExpression, Formula1:="=" & cells(address, 4 + CodeList.count).address(False) & ">1"
.FormatConditions(1).Interior.Color = RGB(215, 150, 148)
.FormatConditions(1).StopIfTrue = False
.FormatConditions.add Type:=xlExpression, Formula1:="=" & cells(address, 4 + CodeList.count).address(False) & "<>" & wb.SCAA.cells(address, "AAA").address(False) & ""
.FormatConditions(2).Interior.Color = RGB(196, 215, 155)
.FormatConditions(2).StopIfTrue = False
End With
End If
Next address
wb.SCAA.Range(columns(2), columns(lastCol)).ColumnWidth = 14
'''' RE-DEFINE THE LAST ROW B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row
'''' LOCK ALL THE CELLS IN SHEET
wb.SCAA.Range(wb.SCAA.cells(1, 1), wb.SCAA.cells(lastRowB + 4, lastCol)).Locked = True
'''' UNLOCK THE PROGRESS COLUMN TO BE ABLE TO CHANGE THE PERCENTAGES
wb.SCAA.Range(wb.SCAA.cells(7, 4 + CodeList.count), wb.SCAA.cells(wb.SCAA.cells(Rows.count, "A").End(xlUp).Row, 4 + CodeList.count)).Locked = False
'''' SET CONTRACT LIST AND CODE LIST TO NOTHING TO AVOID MEMORY LEAKS
Set ContractList = Nothing
Set CodeList = Nothing
Just a thought but you have a LOT of variables defined as the variant type:
For example, in the declaration line you have:
Dim lastRowWIR, lastRowPH, lastRowCODES, lastRow, lastCol As Long
Here, only lastCol is defined as Long, all the rest are variant type, that's a VBA quirk.
Redefining all as set types where possible may help your process speed.
I have a worksheet called "Data" which stores 9 columns of address fields. The sheet is locked to prevent accidental deletion of cells. All amendments have to be carried out using a Userform
This sub defines the data range:
Private Sub UserForm_Initialize()
Dim LastRow as Long
LastRow = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Data").Range("A1:I" & LastRow).Name = "ListName"
ComboBox1.RowSource = "ListName"
ComboBox1.ListIndex = 0
End Sub
The next sub changes the form contents when Combobox 1 is changed:
Private Sub ComboBox1_Change()
With ComboBox1
TextBox30.Value = Range(.RowSource).Cells(.ListIndex + 1, 1)
TextBox31.Value = Range(.RowSource).Cells(.ListIndex + 1, 2)
TextBox32.Value = Range(.RowSource).Cells(.ListIndex + 1, 3)
TextBox33.Value = Range(.RowSource).Cells(.ListIndex + 1, 4)
TextBox34.Value = Range(.RowSource).Cells(.ListIndex + 1, 5)
TextBox35.Value = Range(.RowSource).Cells(.ListIndex + 1, 6)
TextBox36.Value = Range(.RowSource).Cells(.ListIndex + 1, 7)
TextBox37.Value = Range(.RowSource).Cells(.ListIndex + 1, 8)
TextBox38.Value = Range(.RowSource).Cells(.ListIndex + 1, 9)
End With
End Sub
The last sub should replace the worksheet contents with the value of the textboxes on the form
Sub CommandButton4_Click()
With ComboBox1
Range(.RowSource).Cells(.ListIndex + 1, 1).Value = TextBox30.Value
Range(.RowSource).Cells(.ListIndex + 1, 2).Value = TextBox31.Value '
Range(.RowSource).Cells(.ListIndex + 1, 3).Value = TextBox32.Value
Range(.RowSource).Cells(.ListIndex + 1, 3).Value = TextBox32.Value
Range(.RowSource).Cells(.ListIndex + 1, 4).Value = TextBox33.Value
Range(.RowSource).Cells(.ListIndex + 1, 5).Value = TextBox34.Value
Range(.RowSource).Cells(.ListIndex + 1, 6).Value = TextBox35.Value
Range(.RowSource).Cells(.ListIndex + 1, 7).Value = TextBox36.Value
Range(.RowSource).Cells(.ListIndex + 1, 8).Value = TextBox37.Value
Range(.RowSource).Cells(.ListIndex + 1, 9).Value = TextBox38.Value
End With
Unload UserForm5
End Sub
The first line (Range(.RowSource).Cells(.ListIndex + 1, 1).Value = TextBox30.Value) is executed in the sub above and the amended value of Textbox30 is pasted on the Data sheet in column A, overwriting the previous value. None of the lines after this are executed. I've even tried moving lines around and each time only the first line is processed.
Can anyone enlighten me as to where I've gone wrong please.
Your control is bound to the range. When you change the range, your control changes, which will trigger its change event, overwriting your textbox values. I suggest you don't use Rowsource at all, but use List to populate the control and then write back to the range using its name:
Private Sub UserForm_Initialize()
Dim LastRow as Long
LastRow = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Data").Range("A1:I" & LastRow).Name = "ListName"
ComboBox1.List= Sheets("Data").Range("ListName").Value
ComboBox1.ListIndex = 0
End Sub
Private Sub ComboBox1_Change()
Dim lIndex as Long
lIndex = ComboBox1.ListIndex + 1
With Sheets("Data").Range("ListName")
TextBox30.Value = .Cells(lIndex, 1).Value
TextBox31.Value = .Cells(lIndex, 2).Value
TextBox32.Value = .Cells(lIndex, 3).Value
TextBox33.Value = .Cells(lIndex, 4).Value
TextBox34.Value = .Cells(lIndex, 5).Value
TextBox35.Value = .Cells(lIndex, 6).Value
TextBox36.Value = .Cells(lIndex, 7).Value
TextBox37.Value = .Cells(lIndex, 8).Value
TextBox38.Value = .Cells(lIndex, 9).Value
End With
End Sub
Sub CommandButton4_Click()
Dim lIndex as Long
lIndex = ComboBox1.ListIndex + 1
Sheets("Data").Range("ListName").Cells(lIndex, 1).Resize(, 9).Value = _
Array(TextBox30.Value, TextBox31.Value, TextBox32.Value, TextBox32.Value, TextBox33.Value, _
TextBox34.Value, TextBox35.Value, TextBox36.Value, TextBox37.Value, TextBox38.Value)
Unload Me
End Sub
I need to reduce the code where am I writing the synatx manytimes for copying and pasting the row values.
Private Sub btn_upload_Click()
'Frm_Mainform.Show
'MsgBox ("Process Complete - Please Check File in Output Folder")
Const FOLDER As String = "C:\SBI_Files\"
On Error GoTo ErrorHandler
Dim i As Integer
i = 18
Dim fileName As String
fileName = Dir(FOLDER, vbDirectory)
Do While Len(fileName) > 0
If Right$(fileName, 4) = "xlsx" Or Right$(fileName, 3) = "xls" Then
i = i + 1
Dim currentWkbk As Excel.Workbook
Set currentWkbk = Excel.Workbooks.Open(FOLDER & fileName)
Cells(i, 1) = fileName
Cells(i + 1, 2) = "Equity"
Cells(i + 2, 2) = "Forex NOOP"
Cells(i + 3, 2) = "Fixed Income Securities ( including CP, CD, G Sec)"
Cells(i + 4, 2) = "Total"
Cells(i, 2) = "Details"
Cells(i, 3) = "Limit"
Cells(i, 4) = "Min Var"
Cells(i, 5) = "Max Var"
Cells(i, 6) = "No. of Breaches"
Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G8:G8").Value
Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H8:H8").Value
Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I8:I8").Value
Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J8:J8").Value
i = i + 1
Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G9:G9").Value
Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H9:H9").Value
Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I9:I9").Value
Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J9:J9").Value
i = i + 1
Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G10:G10").Value
Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H10:H10").Value
Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I10:I10").Value
Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J10:J10").Value
i = i + 1
Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G11:G11").Value
Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H11:H11").Value
Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I11:I11").Value
Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J11:J11").Value
i = i + 1
currentWkbk.Close
End If
fileName = Dir
Loop
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
You can replace all your Cells lines with these 4
update: added line for coping formats
'other code
Set currentWkbk = Excel.Workbooks.Open(FOLDER & fileName)
Cells(i, 1) = fileName
Cells(i + 1, 2).Resize(4, 1) = Application.Transpose(Array("Equity", "Forex NOOP", "Fixed Income Securities ( including CP, CD, G Sec)", "Total"))
Cells(i, 2).Resize(1, 5) = Array("Details", "Limit", "Min Var", "Max Var", "No. of Breaches")
Cells(i + 1, 3).Resize(4, 4) = currentWkbk.Sheets("VaR").Range("G8:J11").Value
currentWkbk.Sheets("VaR").Range("G8:J11").Copy Cells(i + 1, 3)
currentWkbk.Close