index match return NA value - vba

I have a vba code that find the value at the intersection of columns and rows.
It works well with all my data except for one : it returns NA.
The value i want to return is the same as usual, it just doesn't work with this intersection.
Can you help me figure out why?
Thank you
With Perftitres
Set VMt = Data1.Range("U:U")
Set Ticker = Data1.Range("H:H")
End With
' Calculs de perf
For Each sht In Perftitres.Worksheets
If sht.Visible = True Then
If sht.Cells(1, 1) = "" Then
sht.Cells(1, 1) = "Date"
sht.Cells(1, 2) = "Code du placement"
sht.Cells(1, 3) = "Valeur marchande t"
sht.Cells(1, 4) = "Valeur marchande t-1"
sht.Cells(1, 5) = "Valeur des achats"
sht.Cells(1, 6) = "Valeur des ventes"
sht.Cells(1, 7) = "Facteur"
sht.Cells(1, 8) = "Rendement 1 mois"
End If
LastRowsht = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
LastColumnsht = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
sht.Cells(LastRowsht + 1, 1) = 20 & Left(Dateupdate, 2) & "-" & Right(Dateupdate, 2)
sht.Cells(LastRowsht + 1, 2) = sht.Name
sht.Cells(LastRowsht + 1, 3) = Application.Index(VMt, Application.Match(sht.Cells(LastRowsht + 1, 2), Ticker))
End If
Next sht
Data1.Visible = True
Data2.Visible = True
This line doesn't work as expected for only one sheet. For every other one it works.
sht.Cells(LastRowsht + 1, 3) = Application.Index(VMt, Application.Match(sht.Cells(LastRowsht + 1, 2), Ticker))


I just found the answer :
sht.Cells(LastRowsht + 1, 3) = Application.Index(VMt, Application.Match(sht.Cells(LastRowsht + 1, 2), Ticker,0),0)
I had to had 0 and 0 for exact matches

Related

Excel VBA Else without if

I want to use a if-function to distingiush between two sceneraios.
For Each Cell In Tabelle3.Range("A" & lastrow2)
Option A: If Cell <> "" Then run code
Option B: If Cell = "" Then skip this empty cell and go on with the next one
Here the whole code:
Sub IfFunction()
Dim lastrow2 As Long
lastrow2 = Tabelle3.Range("A" & Rows.Count).End(xlUp).Row
Set myrange2 = Tabelle8.UsedRange
For i = 2 To lastrow2
For Each Cell In Tabelle3.Range("A" & lastrow2)
If Cell = "" Then i = i + 1
Else: i = i
Tabelle3.Cells(7 + i, 19) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 3, False)
Tabelle3.Cells(7 + i, 20) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 4, False)
Tabelle3.Cells(7 + i, 21) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 5, False)
Next i
End If
End Sub
When I try to run this code, it does not execute because an error occurs that there is a 'ELSE without IF'-Function.
Does anyone know how I can use an IF-function here or what to use instead? Thanks. :)

if you continue writing after Then this means the If statement consists of one line only:
If Cell = "" Then i = i + 1 'End If automatically here
Then the Else has to be in that line too:
If Cell = "" Then i = i + 1 Else i = i 'End If automatically here
If you want to use a multi line If statement
If Cell = "" Then
i = i + 1
Else
i = i
End If
But …
because i = i doesn't do anything you can just write
If Cell = "" Then i = i + 1
and omit the Else part completely because it does nothing at all.
And anther but …
because you are using a For i the Next i increments i automatically and you don't need to increment it yourself. There is no i = i + 1 needed

your code has to For but one Next only, which would result in a syntax error
furthermore the Next i is intertwined with a If-Then-Else block code which would also result in a syntax error
finally I guess you're iterating twice along Tabelle3 column A cells from row 2 to last not empty one, while you only need it once
Summing all that up, I'd say you can use this code:
Option Explicit
Sub IfFunction()
Dim myrange2 As Range, cell As Range
Set myrange2 = Tabelle8.UsedRange
With Tabelle3
For Each cell In .Range("A2:A" & .Cells(.Rows.count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
cell.Offset(7, 18) = Application.WorksheetFunction.VLookup(cell.Offset(7), myrange2, 3, False)
cell.Offset(7, 19) = Application.WorksheetFunction.VLookup(cell.Offset(7), myrange2, 4, False)
cell.Offset(7, 20) = Application.WorksheetFunction.VLookup(cell.Offset(7), myrange2, 5, False)
Next
End With
End Sub

Okay that was actually way to simple :D I was running through the same column twice by
For Each Cell In Tabelle3.Range("A" & lastrow2)
If Cell = "" Then i = i + 1
Else: i = i
and
For i = 2 To lastrow2
Instead I can simply use:
For i = 2 To lastrow2
If Tabelle3.Cells(7 + i, 1) <> "" Then
Tabelle3.Cells(7 + i, 19) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 3, False)
Tabelle3.Cells(7 + i, 20) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 4, False)
Tabelle3.Cells(7 + i, 21) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange2, 5, False)
End if
Next i
Thanks alot for your help & contribution!

VBA stops running when value is written in a cell

I am organizing a dirty text in an organised table. And this code stops when the cell the marked line is completed. Can you help me to make it continuing the loop?
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim sh7 As Worksheet
Dim CNAME As String
Set sh = Worksheets("Sheet6")
Set sh7 = Worksheets("Sheet7")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
For n = 1 To lr
If InStr(1, sh.Cells(n, 1), "CALL:") = 1 Then
CNAME = sh.Cells(n, 7).Value
Ci = sh.Cells(n + 1, 7).Value
Cpd = sh.Cells(n + 1, 7).Value
Else
If InStr(1, sh.Cells(n, 1), "Topic:") = 1 Then
T = sh.Cells(n, 2)
Tpd = sh.Cells(n + 1, 2)
Types = sh.Cells(n + 4, 2)
DM = sh.Cells(n + 5, 2)
D = sh.Cells(n + 5, 4)
OD = sh.Cells(n + 6, 2)
lr7 = sh7.Cells(Rows.Count, 1).End(xlUp).Row
sh7.Cells(lr7 + 1, 1).Value = CNAME '********This is the last line it runs.
sh7.Cells(lr7 + 1, 2).Value = Ci
sh7.Cells(lr7 + 1, 3).Value = Cpd
sh7.Cells(lr7 + 1, 4).Value = T
sh7.Cells(lr7 + 1, 5).Value = Tpd
sh7.Cells(lr7 + 1, 6).Value = Types
sh7.Cells(lr7 + 1, 7).Value = DM
sh7.Cells(lr7 + 1, 8).Value = D
sh7.Cells(lr7 + 1, 9).Value = OD
End If
End If
Next n
End Sub

You should get in the habit of defining all variables and supplying a default value.
EDIT:
It seems my original conclusion was incorrect. Upon further inspection I see what might be an issue in your code. Both times where you are trying to get the last row, you are using Rows.Count as a parameter.
Maybe change these
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
lr7 = sh7.Cells(Rows.Count, 1).End(xlUp).Row
To this (note that I use the sheet variable in the first param)
lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
lr7 = sh7.Cells(sh7.Rows.Count, 1).End(xlUp).Row

CountIf Application or object defined error

I've got a code that keeps on returning a run-time error 1004 - Application-defined or object-defined error. I've tried stepping through the individual parts of the worksheetfunction.countif function, and they all work fine separately.
However, when I put them together, they fail.
The code is:
s = 2
While Cells(s - 1, 1) <> vbNullString
Rows(s & ":" & s + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(s, 1), Cells(s + 3, 1)).Select
Selection.Rows.Group
Cells(s, 1) = "A"
Cells(s + 1, 1) = "B"
Cells(s + 2, 1) = "C"
Cells(s + 3, 1) = "D"
r = 3
q = vbNullString
p = vbNullString
n = s
While n < s + 5
While r <= v
M = 1
If Cells(n, 1) = "A" Then
q = 5
p = 12
ElseIf Cells(n, 1) = "B" Then
q = 18
p = 25
ElseIf Cells(n, 1) = "C" Then
q = 31
p = 38
ElseIf Cells(n, 1) = "D" Then
q = 44
p = 51
End If
While M <= u
l = vbNullString
l = WorksheetFunction.CountIf(Worksheets("IT Teams").Range(Cells(q, M), Cells(p, M)), Worksheets("Players IT").Cells(s + 4, 1))
If Not IsError(l) Then
Cells(n, r) = l
Else
Cells(n, r) = vbNullString
End If
M = M + 5
r = r + 1
Wend
Wend
n = n + 1
r = 3
Wend
s = s + 5
Wend
All variables have been declared as Variants.
Edit: for clarity. Error occurs at:
l = WorksheetFunction.CountIf(Worksheets("IT Teams").Range(Cells(q, M), Cells(p, M)), Worksheets("Players IT").Cells(s + 4, 1))

The problem is the way you declare the ranges. You should always include the sheet, otherwise you get this error, if you use more than one sheet (or if you use one, but it is not the active one).
Like this:
With ActiveSheet
While Cells(s - 1, 1) <> vbNullString
.Rows(s & ":" & s + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range(.Cells(s, 1), .Cells(s + 3, 1)).Select
Selection.Rows.Group
.Cells(s, 1) = "A"
.Cells(s + 1, 1) = "B"
.Cells(s + 2, 1) = "C"
.Cells(s + 3, 1) = "D"
Wend
End With
Pay attention to the dots.
In general, declare the sheets and then use them:
'Option Explicit - start using option explicit
Sub test()
Dim wksA As Worksheet
Dim wksIT As Worksheet
Set wksA = ThisWorkbook.ActiveSheet
Set wksIT = ThisWorkbook.Worksheets("IT Teams")
s = 2
While Cells(s - 1, 1) <> vbNullString
wksA.Rows(s & ":" & s + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
wksA.Range(wksA.Cells(s, 1), wksA.Cells(s + 3, 1)).Select
Selection.Rows.Group
wksA.Cells(s, 1) = "A"
wksA.Cells(s + 1, 1) = "B"
wksA.Cells(s + 2, 1) = "C"
wksA.Cells(s + 3, 1) = "D"
Wend
With wksIT
While M <= u
l = vbNullString
l = WorksheetFunction.CountIf(.Range(.Cells(q, M), _
.Cells(p, M)), .Cells(s + 4, 1))
If Not IsError(l) Then
.Cells(n, r) = l
Else
.Cells(n, r) = vbNullString
End If
M = M + 5
r = r + 1
Wend
End With
End Sub
Concerning your case, I am about 80% sure, that you get the error somewhere here:
l = WorksheetFunction.CountIf(Range(Cells(q, M), Cells(p, M)), Cells(s + 4, 1))
In general, never assume which worksheet your code is operating on and explicitly define it in your code.
Concerning the place where you get the error, it should be simply like this:
Set wksA = ThisWorkbook.ActiveSheet
Set wksIT = ThisWorkbook.Worksheets("IT Teams")
Set wksPl = ThisWorkbook.Worksheets("SomePlayers")
l = WorksheetFunction.CountIf(wksIT.Range(wksIT.Cells(q, M), wksIT.Cells(p, M)), _
wksPl.Cells(s + 4, 1))

VBA Group Properties by Street Name

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.

Excel vba For Each & For loop

lastColumn_Of_PO_line_Big_Table = Sheets("PO_line_Big_Table").UsedRange.Columns.Count + 1
a = Dict_Metadata.Keys
For Each b In a
For i = 1 To UBound(Arr_PO_line_Big_Table)
If Arr_PO_line_Big_Table(i, 1) = b Then
With Worksheets("PO_line_Big_Table")
nextRow = Sheets("Final_Result").Cells(Sheets("Final_Result").Rows.Count, 1).End(xlUp).row + 1
'.Cells(nextRow, "A") = strKey
'.Cells(i + 1, lastColumn_Of_PO_line_Big_Table) = "YES"
Union(.Cells(i + 1, "E"), .Cells(i + 1, "K"), .Cells(i + 1, "L"), .Cells(i + 1, "M")).Copy
Sheets("Final_Result").Range("B" & nextRow).PasteSpecial
End With
End If
Next
Next
Could someone please tell me why it doesn't paste the value in sheet "PO_line_Big_Table" to sheet Final_Result, thank you in advanced!!