How to show results on desired sheet? - excel

The below code is not showing the results on the "All Stock Analysis" sheet.
I tried doing a test after the activation of each worksheet (Range("I1).Interior.Color = vbGreen) and cell I1 turns green on each of the desired worksheets. What other tests can I try? No error msg pops up.
Sub AllStocksAnalysisRefactored()
Dim startTime As Single
Dim endTime As Single
yearValue = InputBox("What year would you like to run the analysis on?")
startTime = Timer
'Format the output sheet on All Stocks Analysis worksheet
Worksheets("All Stock Analysis").Activate
Range("A1").Value = "All Stocks (" + yearValue + ")"
'Create a header row
Cells(3, 1).Value = "Ticker"
Cells(3, 2).Value = "Total Daily Volume"
Cells(3, 3).Value = "Return"
'Initialize array of all tickers
Dim tickers(12) As String
tickers(0) = "AY"
tickers(1) = "CSIQ"
tickers(2) = "DQ"
tickers(3) = "ENPH"
tickers(4) = "FSLR"
tickers(5) = "HASI"
tickers(6) = "JKS"
tickers(7) = "RUN"
tickers(8) = "SEDG"
tickers(9) = "SPWR"
tickers(10) = "TERP"
tickers(11) = "VSLR"
'Activate data worksheet
Worksheets(yearValue).Activate
'Get the number of rows to loop over
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
'1a) Create a ticker Index
Dim tickerIndex As Single
tickerIndex = 0
'1b) Create three output arrays
Dim tickerVolumes(12) As LongLong
Dim tickerstartingPrices(12) As Single
Dim tickerendingPrices(12) As Single
''2a) Create a for loop to initialize the tickerVolumes to zero.
For i = 0 To 11
tickerVolumes(i) = 0
''2b) Loop over all the rows in the spreadsheet.
For j = 2 To RowCount
'3a) Increase volume for current ticker
tickerVolumes(tickerIndex) = tickerVolumes(tickerIndex) + Cells(j, 8).Value
'3b) Check if the current row is the first row with the selected tickerIndex.
'If Then
If Cells(j - 1, 1).Value <> tickers(tickerIndex) And _
Cells(j, 1).Value = tickers(tickerIndex) Then
tickerstartingPrices(tickerIndex) = Cells(j, 6).Value
'End If
End If
'3c) check if the current row is the last row with the selected ticker
'If the next row’s ticker doesn’t match, increase the tickerIndex.
'If Then
If Cells(j + 1, 1).Value <> tickers(tickerIndex) And _
Cells(j, 1).Value = tickers(tickerIndex) Then
tickerendingPrices(tickerIndex) = Cells(j, 6).Value
'3d Increase the tickerIndex.
tickerIndex = tickerIndex + 1
'End If
End If
Next j
Next i
'4) Loop through your arrays to output the Ticker, Total Daily Volume, and Return.
For i = 0 To 11
Worksheets("All Stock Analysis").Activate
Next i
'Formatting
Worksheets("All Stock Analysis").Activate
Range("A3:C3").Font.FontStyle = "Bold"
Range("A3:C3").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("B4:B15").NumberFormat = "#,##0"
Range("C4:C15").NumberFormat = "0.0%"
Columns("B").AutoFit
dataRowStart = 4
dataRowEnd = 15
For i = dataRowStart To dataRowEnd
If Cells(i, 3) > 0 Then
Cells(i, 3).Interior.Color = vbGreen
Else
Cells(i, 3).Interior.Color = vbRed
End If
Next i
endTime = Timer
MsgBox "This code ran in " & (endTime - startTime) & _
" seconds for the year " & (yearValue)
End Sub
Here is how "All Stock Analysis" sheet will look after running the code:

You only need to scan the data sheet once if you use a dictionary object to convert the ticker ID to an array index number.
Option Explicit
Sub AllStocksAnalysisRefactored()
Const SHT_NAME = "All Stock Analysis"
Dim wb As Workbook, ws As Worksheet, wsYr As Worksheet
Dim cell As Range, yr As String, iRow As Long, iLastRow As Long
Dim t As Single: t = Timer
' choose data worksheet
yr = InputBox("What year would you like to run the analysis on ? ", "Enter Year", Year(Date))
Set wb = ThisWorkbook
On Error Resume Next
Set wsYr = wb.Sheets(yr)
On Error GoTo 0
' check if exists
If wsYr Is Nothing Then
MsgBox "Sheet '" & yr & "' does not exists.", vbCritical, "Error"
Exit Sub
End If
'Initialize array of all tickers
Dim tickerID, tickerData(), i As Integer, n As Integer
Dim dict As Object, sId As String
tickerID = Array("AY", "CSIQ", "DQ", "ENPH", "FSLR", "HASI", _
"JKS", "RUN", "SEDG", "SPWR", "TERP", "VSLR")
n = UBound(tickerID) + 1
ReDim tickerData(1 To n, 1 To 5)
' create dict id to index
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To n
sId = UCase(Trim(tickerID(i - 1)))
tickerData(i, 1) = sId ' id
tickerData(i, 2) = 0 ' volume
tickerData(i, 3) = 0 ' start price
tickerData(i, 4) = 0 ' finish price
tickerData(i, 5) = 0 ' count
dict.Add sId, i
Next
'Get the number of rows to loop over
iLastRow = wsYr.Cells(Rows.Count, "A").End(xlUp).Row
' Loop over all the rows in the spreadsheet.
' A=ticker, F=Price , H=Volume
For iRow = 2 To iLastRow
sId = UCase(Trim(wsYr.Cells(iRow, "A")))
If dict.exists(sId) Then
i = dict(sId)
' volume
tickerData(i, 2) = tickerData(i, 2) + wsYr.Cells(iRow, "H") ' volume
' start price when count is 0
If tickerData(i, 5) = 0 Then
tickerData(i, 3) = wsYr.Cells(iRow, "F")
End If
' end price
tickerData(i, 4) = wsYr.Cells(iRow, "F")
' count
tickerData(i, 5) = tickerData(i, 5) + 1
End If
Next
'Format the output sheet on All Stocks Analysis worksheet
Set ws = wb.Sheets(SHT_NAME)
ws.Cells.Clear
With ws
.Range("A1").Value2 = "All Stocks (" & yr & ")"
With .Range("A3:E3")
.Value2 = Array("Ticker", "Total Daily Volume", "Start Price", "End Price", "Return")
.Font.FontStyle = "Bold"
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
.Range("A4").Resize(n, 4).Value2 = tickerData
.Range("B4:D4").Resize(n).NumberFormat = "#,##0"
.Range("E4").Resize(n).NumberFormat = "0.0%"
.Columns("B").AutoFit
End With
' coloring
For Each cell In ws.Range("E4").Resize(n)
cell.FormulaR1C1 = "=(RC[-1]-RC[-2])/RC[-2]" ' end-start/start
If cell > 0 Then
cell.Interior.Color = vbGreen
Else
cell.Interior.Color = vbRed
End If
Next
ws.Activate
ws.Range("A1").Select
MsgBox "This code ran for (" & yr & ")", vbInformation, Int(Timer - t) & " seconds"
End Sub

Related

Compare two columns from which one column is not mandatory

I need help for a macro code.
In my case the excel macro checks data in one sheet ("Check_file") for completeness and correctness.
There are mandatory columns in the sheet which have to exist and also not-mandatory columns can exist.
In my example the columns “company” and “fee” are mandatory columns, if they are missing or false the macro will throw an error.
Next to them, the column “gross fee” is not-mandatory and its data should only be checked with the data in column “fee”, if column “gross fee” exists. If it exists, the amount should be the same as in column “fee”. If it doesnt exist, there should be no comparison.
The check for the mandatory columns works fine within a For-Loop and an own Range.
My problem is that I dont know how I can involve the not-mandatory columns into the loop of the mandatory columns…
I tried to define a separate Range for the not-mandatory columns area. But it seems that I cannnot create the connection to the not-mandatory column if it is not set in the mandatory columns loop. But if it is set to the mandatory columns range and the not-mandatory column doesnt exist, an error will be thrown.
Should the exist-check for the not-mandatory columns be placed in a separate Sub or Function? If yes, how can the connection be created to the mandatory check Range?
This is the vba code:
Function Main_Check(ByVal StrFilePath As String) As String
'//Checks all criteria for the correct filling of the template. Marks all fields that are incorrectly
filled in red.
Dim WB As Workbook, WS As Worksheet
Dim i As Long, iNotMand As Long, lEnde As Long, strHeader As String, ii As Long, lColEnde As Long
Dim rngFind As Range, booCheck As Boolean, rngHeader As Range, rngKey As Range, rngUsed As Range,
rngHeaderNotMand As Range, rngFindNotMand As Range, rngKeyGrossFee As Range, rngGrossFee As Range
Dim strKey As String, arrKey As String, strKeyGrossFee As String, strGrossFee As String
On Error GoTo ErrorHandler
If StrFilePath = “” Then GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'//Template is opened
Set WB = Workbooks.Open(StrFilePath)
Set WS = WB.Worksheets(“Check_file”)
With WS
.Cells.EntireColumn.AutoFit
'//Stores the last row and column to be processed
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row
lColEnde = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
'//Find the beginning of the table
Set rngFind = .Cells.Find(what:=Settings.Cells(Settings.Range("Header_Start").Row + 1, 2).Value,
LookIn:=xlValues, lookat:=xlWhole)
If rngFind Is Nothing Then
booCheck = False
End
End If
.Range(rngFind.Address, .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row,
rngFind.Column)).EntireRow.Hidden = False
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row
'//booCheck is set to true and on error to false _
Thus, if "True" is passed, the complete file is correct
Set rngUsed = .Range(rngFind.Address, .Cells(lEnde, lColEnde))
booCheck = IsErrorAll(rngUsed)
'//Header Check _
Checks all headers in advance to see if they are present and writes the missing ones in a cell
.Cells(4, 7).Clear
.Cells(4, 8).Clear
For i = Settings.Range("Header_Start").Row + 1 To Settings.Range("Header_Ende").Row - 1
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=Settings.Cells(i, 2).Value,
LookIn:=xlValues, lookat:=xlWhole)
If rngHeader Is Nothing Then
booCheck = False
.Cells(4, 7).Value = "The following column labels were not found: "
If .Cells(4, 8).Value = "" Then
.Cells(4, 8).Value = .Cells(4, 8).Value & Settings.Cells(i, 2).Value
Else
.Cells(4, 8).Value = "," & .Cells(4, 8).Value & Settings.Cells(i, 2).Value
End If
.Cells(4, 8).Interior.Color = vbRed
Else
End If
Next i
If booCheck = False Then GoTo Ende
'// Check Not-Mandatory Columns _
Checks in advance whether Not-mandatory columns are available
Set rngFindNotMand = .Cells.Find(what:=Settings.Cells(Settings.Range("NotMand_Start").Row + 1, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
For iNotMand = Settings.Range("NotMand_Start").Row + 1 To Settings.Range("NotMand_Ende").Row - 1
Set rngHeaderNotMand = .Range(rngFindNotMand, .Cells(rngFindNotMand.Row, lColEnde)).Find(what:=Settings.Cells(iNotMand, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
If Not rngHeaderNotMand Is Nothing Then
'//Not-mandatory columns are defined
strKeyGrossFee = "Gross fee"
Set rngKeyGrossFee = Settings.Cells(1, 1).EntireColumn.Find(what:=strKeyGrossFee, LookIn:=xlValues, lookat:=xlWhole)
strGrossFee = Settings.Cells(rngKeyGrossFee.Row, 2).Value
Else
strKeyGrossFee = ""
End If
'//All line items are run through and the individual criteria are checked
For i = rngFind.Row + 1 To lEnde Step 1
'//Company
strKey = "Company"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
iCoi = rngHeader.Column
If .Cells(i, rngHeader.Column).Value Like "####" Then
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
Else
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
End If
'//Fee
strKey = "Fee"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
If .Cells(i, rngHeader.Column).Value Like "*,*" Then
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
Else
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
End If
'//Gross fee
strKey = "Fee"
Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
strHeader = Settings.Cells(rngKey.Row, 2).Value
Set rngHeader = .Range(rngFind, .Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
Set rngFindNotMand = .Cells.Find(what:=Settings.Cells(Settings.Range("NotMand_Start").Row + 1, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
strKeyGrossFee = "Gross fee"
Set rngKeyGrossFee = Settings.Cells(1, 1).EntireColumn.Find(what:=strKeyGrossFee, LookIn:=xlValues, lookat:=xlWhole)
strGrossFee = Settings.Cells(rngKeyGrossFee.Row, 2).Value
Set rngGrossFee = .Range(rngFindNotMand, .Cells(rngFindNotMand.Row, lColEnde)).Find(what:=strGrossFee, LookIn:=xlValues, lookat:=xlWhole)
If .Cells(i, rngGrossFee.Column).Value Is Nothing Then
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
ElseIf .Cells(i, rngHeader.Column).Value <> .Cells(i, rngGrossFee.Column).Value Then
.Cells(i, rngHeader.Column).Interior.Color = vbRed
booCheck = False
Else
.Cells(i, rngHeader.Column).Interior.Pattern = xlNone
End If
Next i
End With
'//Define results
Ende:
Main_Check = booCheck & “,” & Replace(CStr(rngFind.Address), “$”, “”)
If booCheck = False Then
WS.Cells(7, 7).Value = “Error counter:”
WS.Cells(7, 8).Value = WS.Cells(7, 8).Value + 1
Else
WS.Cells(7, 7).Value = “Check ok”
WS.Cells(7, 8).Value = “”
End If
WB.Close (True)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Function
'//If there are other errors, it should exit here and return ERROR
ErrorHandler:
On Error GoTo -1
On Error Resume Next
Main_Check = “ERROR”
WB.Close (True)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Function
I would recommend you refactor your code into 3 parts. 1- read the settings, 2- profile the sheet and then 3- check the data. Debug each step in turn.
Function Main_Check2(ByVal StrFilePath As String) As String
Const CHECK = "Check_file"
Dim wb As Workbook, ws As Worksheet, arHdr
Dim booCheck As Boolean, bExists As Boolean
Dim iColFee As Long, i As Long, msg As String
' check valid filepath
If Dir(StrFilePath) = "" Then
msg = "'" & StrFilePath & "' does not exist"
MsgBox msg, vbCritical, "File not found"
Main_Check2 = msg
Exit Function
End If
' open file and check sheet exists
Set wb = Workbooks.Open(StrFilePath)
bExists = False
For Each ws In wb.Sheets
If ws.Name = CHECK Then
bExists = True
Exit For
End If
Next
If Not bExists Then
msg = "Sheet '" & CHECK & "' not found in " & wb.FullName
MsgBox msg, vbCritical, "Sheet not found"
wb.Close False
Exit Function
End If
' get header details from settings sheet
Call GetSettings(Settings, arHdr)
' check headers, find fee column
booCheck = CheckHeaders(ws, arHdr, iColFee)
'Call DumpArray(arHdr) ' check results so far
' exit if false
If booCheck = False Then
Main_Check2 = booCheck
Exit Function
End If
' check data
With ws
'//All line items are run through and the individual criteria are checked
Dim rngData As Range, sName As String, n As Long
Dim iRow As Long, iCol As Long, lastrow As Long, cell As Range
For i = 1 To UBound(arHdr)
sName = arHdr(i, 1) ' header name
iCol = arHdr(i, 4) ' header column
iRow = arHdr(i, 5) ' header row
n = arHdr(i, 6) ' number of rows
' scan column
If iCol > 0 And n > 0 Then
Set rngData = .Cells(iRow + 1, iCol).Resize(n)
Select Case sName
Case "Company"
For Each cell In rngData
If cell.Value Like "####" Then
cell.Interior.Pattern = xlNone
Else
cell.Interior.Color = vbRed
booCheck = False
End If
Next
Case "Fee"
For Each cell In rngData
If Not cell.Value Like "*,*" Then
cell.Interior.Pattern = xlNone
Else
cell.Interior.Color = vbRed
booCheck = False
End If
Next
Case "Gross Fee"
' optional - skipped if icol = 0
For Each cell In rngData
If Len(cell) = 0 Then
cell.Interior.Pattern = xlNone
ElseIf cell.Value <> .Cells(cell.Row, iColFee).Value Then
cell.Interior.Color = vbRed
booCheck = False
Else
cell.Interior.Pattern = xlNone
End If
Next
End Select
End If
Next
End With
'//Define results
Ende:
If booCheck = False Then
ws.Cells(7, 7).Value = "Error counter:"
ws.Cells(7, 8).Value = ws.Cells(7, 8).Value + 1
Else
ws.Cells(7, 7).Value = "Check ok"""
ws.Cells(7, 8).Value = ""
End If
'wb.Close True
Main_Check2 = booCheck '& "," & Replace(CStr(rngFind.Address), "$", "")
End Function
Function GetSettings(ws, ByRef arHdr) As Boolean
Dim r1 As Long, r2 As Long, r3 As Long, r4 As Long
Dim n As Long, m As Long, i As Long, msg As String
With ws
r1 = .Range("Header_Start").Row
r2 = .Range("Header_Ende").Row
r3 = .Range("NotMand_Start").Row
r4 = .Range("NotMand_Ende").Row
m = r2 - r1 - 1 ' mandatory header
n = r4 - r3 - 1 ' non-mandatory headers
If m < 1 Then
msg = "No mandatory headers on setting"
MsgBox msg, vbExclamation, "Settings Error"
getSettings = False
End If
' size array and fill
ReDim arHdr(1 To n + m, 1 To 6)
For i = 1 To m
arHdr(i, 1) = .Cells(r1 + i, 1)
arHdr(i, 2) = .Cells(r1 + i, 2) ' search term
If Len(arHdr(i, 2)) > 0 Then ' skip blanks
arHdr(i, 3) = True ' mandatory
Else
arHdr(i, 3) = False
End If
Next
For i = 1 To n
arHdr(m + i, 1) = .Cells(r3 + i, 1)
arHdr(m + i, 2) = .Cells(r3 + i, 2)
arHdr(m + i, 3) = False ' optional
Next
End With
getSettings = True
End Function
Function CheckHeaders(ws, ByRef arHdr, ByRef iColFee) As Boolean
'//Header Check
'Checks all headers in advance to see if they are present
'and writes the missing ones in a cell
Dim rngTable As Range, rng As Range
Dim msg As String, sHdr As String, sTableStart As String
Dim i As Long, lastrow As Long, rowHdr As Long
Dim booCheck As Boolean
' search value for column 1 of table
sTableStart = arHdr(1, 2)
With ws
'//Find the beginning of the table
Set rngTable = .Cells.Find(what:=sTableStart, LookIn:=xlValues, lookat:=xlWhole)
If rngTable Is Nothing Then
msg = "Could not find begining of table '" & sTableStart & "'"
MsgBox msg, vbExclamation, "Error"
CheckHeaders = False
Exit Function
Else
rowHdr = rngTable.Row
End If
For i = 1 To UBound(arHdr)
sHdr = Trim(arHdr(i, 2))
If Len(sHdr) > 0 Then ' skip blanks
Set rng = .Rows(rowHdr).Find(what:=sHdr, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
arHdr(i, 4) = 0
Else
' store fee column for later gross fee check
If arHdr(i, 1) = "Fee" Then iColFee = rng.Column
arHdr(i, 4) = rng.Column
arHdr(i, 5) = rng.Row
lastrow = .Cells(.Rows.Count, rng.Column).End(xlUp).Row
arHdr(i, 6) = lastrow - rng.Row - 1 ' data rows
End If
Else
arHdr(i, 4) = 0
End If
Next
' check for mandatory column errors
Dim sep As String
For i = 1 To UBound(arHdr)
If arHdr(i, 3) And arHdr(i, 4) = 0 Then
msg = msg & sep & arHdr(i, 2)
sep = ","
End If
Next
If Len(msg) > 0 Then
.Cells(4, 7) = "The following column labels were not found: "
.Cells(4, 8) = msg
.Cells(4, 8).Interior.Color = vbRed
CheckHeaders = False
'GoTo Ende
Else
.Cells(4, 7).Clear ' G4
.Cells(4, 8).Clear ' H4
CheckHeaders = True
End If
End With
End Function
' dump array to new workbook to debug
Sub DumpArray(ar)
Dim wb As Workbook: Set wb = Workbooks.Add
With wb.Sheets(1)
.Name = "arHdr"
.Range("A1:F1") = Array("Header1", "Header2", "Mandatory", "Column", "Row", "DataRows")
.Range("A2").Resize(UBound(ar), UBound(ar, 2)) = ar
End With
' save - replace existing
Application.DisplayAlerts = False
wb.SaveAs "debug_arHdr.xlsx"
Application.DisplayAlerts = True
'wb.Close
End Sub

VBA Overflow Error 6 - Receiving error calculating output of stock prices

I am getting an error in the macro I'm working on for a bootcamp project. The idea is that I have refactored the code to make it more efficient, but I'm getting an Overflow error on one of the lines. I think it's due to it trying to divide 0, but I don't know where I've gone wrong in the loop that it is pulling data that would divide by 0. Any ideas? I'm getting the error on this line
Cells(4 + i, 3).Value = EndingPrices(i) / StartingPrices(i) - 1
in section 4 - '4) Loop through your arrays to output the Ticker, Total Daily Volume, and Return.
Sub AllStocksAnalysisRefactored()
Dim startTime As Single
Dim endTime As Single
yearValue = InputBox("What year would you like to run the analysis on?")
startTime = Timer
'Format the output sheet on All Stocks Analysis worksheet
Worksheets("All Stocks Analysis").Activate
Range("A1").Value = "All Stocks (" + yearValue + ")"
'Create a header row
Cells(3, 1).Value = "Ticker"
Cells(3, 2).Value = "Total Daily Volume"
Cells(3, 3).Value = "Return"
'Initialize array of all tickers
Dim tickers(12) As String
tickers(0) = "AY"
tickers(1) = "CSIQ"
tickers(2) = "DQ"
tickers(3) = "ENPH"
tickers(4) = "FSLR"
tickers(5) = "HASI"
tickers(6) = "JKS"
tickers(7) = "RUN"
tickers(8) = "SEDG"
tickers(9) = "SPWR"
tickers(10) = "TERP"
tickers(11) = "VSLR"
'Activate data worksheet
Worksheets(yearValue).Activate
'Get the number of rows to loop over
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
'1a) Create a ticker Index
Dim tickerIndex As Integer
tickerIndex = 0
'1b) Create three output arrays
Dim tickerVolumes(12) As Long
Dim StartingPrices(12) As Long
Dim EndingPrices(12) As Long
''2a) Create a for loop to initialize the tickerVolumes to zero.
For i = 0 To 11
tickerVolumes(i) = 0
Next i
''2b) Loop over all the rows in the spreadsheet.
For i = 2 To RowCount
'3a) Increase volume for current ticker
If Cells(i, 1).Value = tickerIndex Then
tickerVolumes(tickerIndex) = tickerVolumes(tickerIndex) + Cells(i, 8).Value
End If
'3b) Check if the current row is the first row with the selected tickerIndex.
'If Then
If Cells(i, 1) = tickerIndex And Cells(i - 1, 1).Value <> tickerIndex Then
StartingPrices(tickerIndex) = Cells(i, 6).Value
End If
'End If
'3c) check if the current row is the last row with the selected ticker
'If the next row’s ticker doesn’t match, increase the tickerIndex.
'If Then
If Cells(i, 1).Value = tickerIndex And Cells(i + 1, 1) <> tickerIndex Then
EndingPrices(tickerIndex) = Cells(i, 6).Value
'3d Increase the tickerIndex.
tickerIndex = tickerIndex + 1
End If
'End If
Next i
'4) Loop through your arrays to output the Ticker, Total Daily Volume, and Return.
For i = 0 To 11
Worksheets("All Stocks Analysis").Activate
tickerIndex = i
Cells(4 + i, 1).Value = tickers(i)
Cells(4 + i, 2).Value = tickerVolumes(i)
Cells(4 + i, 3).Value = EndingPrices(i) / StartingPrices(i) - 1 ' **this line is causing the error**
Next i
'Formatting
Worksheets("All Stocks Analysis").Activate
Range("A3:C3").Font.FontStyle = "Bold"
Range("A3:C3").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("B4:B15").NumberFormat = "#,##0"
Range("C4:C15").NumberFormat = "0.0%"
Columns("B").AutoFit
dataRowStart = 4
dataRowEnd = 15
For i = dataRowStart To dataRowEnd
If Cells(i, 3) > 0 Then
Cells(i, 3).Interior.Color = vbGreen
Else
Cells(i, 3).Interior.Color = vbRed
End If
Next i
endTime = Timer
MsgBox "This code ran in " & (endTime - startTime) & " seconds for the year " & (yearValue)
End Sub

logic causing variable not to pass to function

I am having an issue getting a variable set to pass to a function properly. The frustrating part is that until yesterday this code has been working properly for a good 4 months of weekly use.
Below is the code, removing the dims and parts of the code that will not help resolve this issue.
Sub Combined_15_and_45()
'Dim Iteration Variables
'Dim tracking variables
'Dim range variables
'Dim Invoice Value Variables
'Dim Email body variables
Set wb = ThisWorkbook
Set WithTerms = Sheet4
Set APEmail = Sheet7
With wb
With WithTerms
lrow = .Cells(Rows.Count, 5).End(xlUp).Row
elrow = Sheet7.Cells(Rows.Count, 1).End(xlUp).Row
CalcDate = .Cells(1, 3).Value
i = 1
'loop through looking for times when cell above is different *Store i Instance
'loop through looking for times when cell below is different *Store i as EndInstance
'Specifically searching for changes in account number
For i = 4 To lrow
h = i - 1
j = i + 1
Set rng = .Cells(i, 5)
Set RngUp = .Cells(h, 5)
Set RngDwn = .Cells(j, 5)
'this is where vendor account changes.
If rng.Value <> RngUp.Value Then
instance = i
End If
'Check if invoice for the line is extreme past due *Store i as MaxOvrDue
If .Cells(i, 10).Value <= .Range("C1").Value - 45 Then
MaxOvrDue = i
End If
'check if invoice for line is +15 day overdue, less than 45 * Store i as MidOvrDur
If .Cells(i, 10).Value <= .Range("C1").Value - 15 Then
If .Cells(i, 10).Value >= .Range("C1").Value - 44 Then
If MidOvrdue = 0 Then
MidOvrdue = i
End If
End If
End If
'Check if Invoice for line is 15+ days overdue (Minimum) *Store i as Ovrdue
If .Cells(i, 10).Value < .Range("C1").Value Then
If .Cells(i, 10).Value <= .Range("C1").Value - 14 Then
OvrDue = i
End If
End If
'figure values for the totals of each section
If rng.Value <> RngDwn.Value Then
EndInstance = i
TotalOverdue = Application.WorksheetFunction.SumIfs(.Range("K:K"), .Range("E:E"), .Cells(instance, 5), .Range("J:J"), "<" & (.Range("c1") - 15))
XtrmOverdue = Application.WorksheetFunction.SumIfs(.Range("K:K"), .Range("E:E"), .Cells(instance, 5), .Range("J:J"), "<" & .Range("C1") - 44)
MidTotalOverdue = Application.WorksheetFunction.SumIfs(.Range("K:K"), .Range("E:E"), .Cells(instance, 5), .Range("J:J"), "<" & .Range("C1") - 15, .Range("J:J"), ">=" & .Range("C1") - 45)
If OvrDue = 0 And MaxOvrDue = 0 And MidOvrdue = 0 Then
Else:
'begin building Extremely Overdue Invoice Text
If MaxOvrDue <> 0 And MidOvrdue = 0 Then
**Set XtrmTblRng = .Range(.Cells(instance, 7), .Cells(MaxOvrDue, 11))**
End If
If OvrDue <> 0 And MidOvrdue <> 0 Then
If MaxOvrDue = 0 And OvrDue <= MidOvrdue Then
**Set MidTblRng = .Range(.Cells(MidOvrdue, 7), .Cells(OvrDue, 11))**
'Begin building ONLY overdue email text
Else:
'begin building segments to add to extreme overdue email
**Set XtrmComboTblRng = .Range(.Cells(instance, 7), .Cells(OvrDue, 11))**
End If
End If
If OvrDue <> 0 Then
'Generate the email
With OutMail
.To = eAddy
'Figure out which email to send
If MaxOvrDue <> 0 And MidTotalOverdue <> 0 Then
.HTMLbody = StrBodyXtrm & RangetoHTML(XtrmComboTblRng, CalcDate) & ComboStrBody2 & StrBody4
Else
If MaxOvrDue <> 0 And MidOvrdue = 0 Then
.HTMLbody = StrBodyXtrm & RangetoHTML(XtrmTblRng, CalcDate) & StrBody2 & StrBody4
Else:
.HTMLbody = StrBodyOverdue & RangetoHTML(MidTblRng, CalcDate) & StrBody3
End If
End If
.display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End If
End If
'clear variables when changing vendor IDs
End If
Set rng = .Cells(j, 5)
Next i
End With
End With
End Sub
Function RangetoHTML(TblRng, CalcDate)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim tRow As Long
Dim i As Long
Dim CalcDate2 As Double
Dim TempDate As Double
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to paste the data in. This is where I am getting errors all the sudden
**TblRng.Copy**
'manipulate the data from table to fit needs and past into email.
End Function
Essentially this is trying to sort through stack of invoices and determine which email format to use.
Invoices aged 45+
Invoices aged 15-45+
Invoices aged 15-44
I am running into an issue with the email determining a different email format should be used than the TblRng variable that has been built to pass to the function. I just cant seem to find my logic error.
I have been banging my head against a wall for a few days now trying to fix this with no luck. Any help you can give will make you a hero in my eyes!
Thank you
The problem with your logic is with this line
If maxOvrDue = 0 And OvrDue <= midOvrDue Then
If there are no >45 lines (maxOvrDue = 0) then at the first occurance of a >15 line
midOvrDue and OvrDue will be the same. On subsequent >15 lines OvrDue will
be greater than midOvrDue. So the above will be true for 1 and false for 2 or more
lines in the 44-15 range. With 2 or more the default Else option will then Set XtrmComboTblRng not MidTblRng.
Later because maxOvrDue = 0 the email .HTMLbody uses RangetoHTML(MidTblRng, CalcDate).
The remedy would be to just use If maxOvrDue = 0 Then.
You could set an email type within the same logic as used to set the ranges so the mismatch can't occur. Here is an example of how to do that
Option Explicit
Sub Combined_15_and_45()
Dim WithTerms As Worksheet, APEMail As Worksheet
Dim rng As Range, tblRng As Range
Dim lrow As Long, elrow As Long, i As Long
Dim instance As Long, maxOvrDue As Long, midOvrDue As Long
Dim CalcDate As Date, DaysLate As Integer, EmailFormat As Integer
Dim has45 As Boolean, has15 As Boolean
Dim acc As String
Dim TotalOverdue As Currency
Dim XtrmOverdue As Currency, MidTotalOverdue As Currency
Set APEMail = Sheet7
elrow = APEMail.Cells(Rows.Count, 1).End(xlUp).row
' for debugging
Dim fso, ts
Set fso = CreateObject("Scripting.FileSystemObject")
' scan down sheet
Set WithTerms = Sheet4
With WithTerms
lrow = .Cells(Rows.Count, "E").End(xlUp).row 'Row E
CalcDate = .Range("C1").Value
For i = 4 To lrow
'this is where vendor account changes.
Set rng = .Cells(i, 5) ' E Account
If rng.Value <> rng.Offset(-1).Value Then
acc = rng
instance = i
maxOvrDue = 0
midOvrDue = 0
XtrmOverdue = 0
MidTotalOverdue = 0
End If
' check days overdue
DaysLate = DateDiff("d", .Cells(i, "J").Value, CalcDate)
If DaysLate >= 45 Then
maxOvrDue = i
XtrmOverdue = XtrmOverdue + .Cells(i, "K")
ElseIf DaysLate >= 15 Then
midOvrDue = i
MidTotalOverdue = MidTotalOverdue + .Cells(i, "K")
End If
' is this last for account
If rng <> rng.Offset(1) Then
TotalOverdue = XtrmOverdue + MidTotalOverdue
Debug.Print vbCr & acc & " Total", XtrmOverdue, MidTotalOverdue, TotalOverdue
has45 = maxOvrDue > 0
has15 = midOvrDue > 0
If has45 Or has15 Then
If has45 And has15 Then
EmailFormat = 1
Set tblRng = .Range(.Cells(instance, 7), .Cells(midOvrDue, 11))
Debug.Print "+45 and +15", tblRng.Address
' begin building segments to add to extreme overdue email
ElseIf has45 Then
EmailFormat = 2
Set tblRng = .Range(.Cells(instance, 7), .Cells(maxOvrDue, 11))
Debug.Print "+45 only", tblRng.Address
' begin building Extremely Overdue Invoice Text
ElseIf has15 Then
EmailFormat = 3
Set tblRng = .Range(.Cells(instance, 7), .Cells(midOvrDue, 11))
Debug.Print "+15 only", tblRng.Address
' begin building ONLY overdue email text
End If
' select email format
Dim body As String
Select Case EmailFormat
Case 1
body = "strBodyXtrm" & RangetoHTML(tblRng, CalcDate) & "ComboStrBody2 & strBody4"
Case 2
body = "strBodyXtrm" & RangetoHTML(tblRng, CalcDate) & "strBody2 & strBody4"
Case 3
body = "strBodyOverdue" & RangetoHTML(tblRng, CalcDate) & "strBody3"
End Select
' create html file for checking
Set ts = fso.createTextFile(ThisWorkbook.Path & "\" & acc & ".html", 1)
ts.write body
ts.Close
'Generate the email
'With outmail
'.To = eAddy
'.HTMLbody = body
'.display
'End with
End If
End If
Next i
End With
MsgBox "Done"
End Sub
Function RangetoHTML(tblRng, CalcDate) As String
Dim s, rw As Range, cell As Range, pre As String
pre = "<pre>TblRng=" & tblRng.Address(External:=1) & "</pre>"
s = "<tr align=""center"" bgcolor=""#ddddff"">" & _
"<th>Col G</th><th>Col H</th><th>Col I</th>" & _
"<th>Col J</th><th>Col K</th></tr>" & vbCrLf
For Each rw In tblRng.Rows
s = s & "<tr>"
For Each cell In rw.Cells
s = s & "<td>" & cell & "</td>"
Next
s = s & "</tr>" & vbCrLf
Next
RangetoHTML = pre & "<table cellspacing=""0"" cellpadding=""3"" border=""1"">" & _
s & "</table>" & vbCrLf
End Function

Fast way to compare two excel files?

I want to compare 2 excels files [Having only 1 sheet in both] having 10-15 columns and rows will be more than 30K. We got one excel macro file which complete the comparison within 5-10Mins. Limitation of this macro is that it can compare only 2-3 columns at a time. So every time we need to run this macro multiple times which is time consuming process. So I created one utility file [.vbs file] which perform this task in one go but it takes around 1-3Hrs.
Is there any other way to perform this comparison in short time in one go?
startTime=Timer()
Set objExcel=Createobject("Excel.application")
objExcel.Visible=True
Set objWorkbook=objExcel.Workbooks.Open("E:\QTP trial version\Data.xls")
'Set deleteAnalysis_CopySheet=objWorkbook.sheets("Analysis_Copy")
'deleteAnalysis_CopySheet.delete
'Set deleteSummarySheet=objWorkbook.sheets("Summary")
'deleteSummarySheet.delete
Set objAnalysis_Copy=objWorkbook.sheets.add
objAnalysis_Copy.name="Analysis_Copy"
Set objSummary=objWorkbook.sheets.add
objSummary.name="Summary"
objSummary.Cells(1,1)="Analysis Row Count"
objSummary.Cells(2,1)="Reporting Row Count"
objSummary.Cells(3,1)="Analysis Column Count"
objSummary.Cells(4,1)="Reporting Column Count"
objSummary.Cells(5,1)="Difference of Row Count"
objSummary.Cells(6,1)="Difference of Column Count"
objSummary.Cells(7,1)="False Count"
' ------------------------1st Check - Verify the position of ''Metrics' in Analysis and Reporting tab. It must be same---------------------
'Get the control of Analysis tab
Set objAnalysis=objExcel.Worksheets.Item("Analysis")
intAnalysisRowCount=objAnalysis.Usedrange.rows.count
objSummary.Cells(1,2)=intAnalysisRowCount
intAnalysisColCount=objAnalysis.Usedrange.Columns.count
objSummary.Cells(3,2)=intAnalysisColCount
'Get Column number of 'Metric' Column from Analysis tab
For intMetricAnalysis=1 to intAnalysisColCount
If(Trim(Lcase(objAnalysis.Cells(1,intMetricAnalysis)))=Trim(Lcase("Metrics"))) Then
Exit for
End If
Next
'Get all Analysis columns in 1 string
strAnalysisColumnOrder=""
For intAnalysisColumnOrder=1 to intAnalysisColCount
strAnalysisColumnOrder=strAnalysisColumnOrder&"*"&objAnalysis.Cells(1,intAnalysisColumnOrder)
If(intAnalysisColumnOrder=1) then
strAnalysisColumnOrder=Replace(strAnalysisColumnOrder,"*","")
End If
Next
Set objReporting=objExcel.Worksheets.Item("Reporting")
intReportingRowCount=objReporting.Usedrange.rows.count
objSummary.Cells(2,2)=intReportingRowCount
intReportingColCount=objReporting.Usedrange.Columns.count
objSummary.Cells(4,2)=intReportingColCount
''Get Column number of 'Metric' Column from Reporting tab
For intMetricReporting=1 to intReportingColCount
If(Trim(Lcase(objReporting.Cells(1,intMetricReporting)))=Trim(Lcase("Metrics"))) Then
Exit for
End If
Next
'Get all Reporting columns in 1 string
strReportingColumnOrder=""
For intReportingColumnOrder=1 to intAnalysisColCount
strReportingColumnOrder=strReportingColumnOrder&"*"&objReporting.Cells(1,intReportingColumnOrder)
If(intReportingColumnOrder=1) then
strReportingColumnOrder=Replace(strReportingColumnOrder,"*","")
End If
Next
''Metric' column number must be same
If(intMetricAnalysis<>intMetricReporting) then
msgbox "Merics column is at "&intMetricAnalysis&" position in 'Analysis' Tab And at "&intMetricReporting&" position in 'Reporting' tab. 'Metrics' column should be at same position in both tab."
strMetricsFlag=False
Else
strMetricsFlag=True
End IF
'-----------2nd Check, Verify count of columns in 'Analysis' And 'Reporting' tab . It Must be same
If intAnalysisColCount<>intReportingColCount Then
msgbox "Column count of 'Reporting' Tab is not same as of 'Analysis tab'."
strAnalysisColCount=False
Else
strAnalysisColCount=True
End If
''---------------3rd Check , Verify Order of columns in 'Analysis' And 'Reporting' tab . It Must be same
If Trim(Lcase(strAnalysisColumnOrder))<>Trim(Lcase(strReportingColumnOrder)) then
msgbox "Column order of 'Reporting' Tab is not same as of 'Analysis tab'. Reporting column order should be "&strAnalysisColumnOrder
strAnalysisColumnOrderFlag=False
Else
strAnalysisColumnOrderFlag=True
End IF
'Creare 'Analysis_Copy' tab and add headers
Set objAnalysisCopy=objExcel.Worksheets.Item("Analysis_Copy")
strFirstCoulmn_AggKeys=""
For intHeaderAggkey=1 to intMetricAnalysis-1
strFirstCoulmn_AggKeys=strFirstCoulmn_AggKeys&"*"&objAnalysis.Cells(1,intHeaderAggkey)
If(intHeaderAggkey=1) then
strFirstCoulmn_AggKeys=Replace(strFirstCoulmn_AggKeys,"*","")
End If
Next
objAnalysisCopy.Cells(1,1)=strFirstCoulmn_AggKeys
strSecondCoulmn_AnalysisMetrics=""
For intHeaderAnalysisMetrics=intMetricAnalysis+1 to intAnalysisColCount
strSecondCoulmn_AnalysisMetrics=strSecondCoulmn_AnalysisMetrics&"*"&objAnalysis.Cells(1,intHeaderAnalysisMetrics)
If(intHeaderAnalysisMetrics=intMetricAnalysis+1 ) then
strSecondCoulmn_AnalysisMetrics=Replace(strSecondCoulmn_AnalysisMetrics,"*","")
End If
Next
objAnalysisCopy.Cells(1,2)="Analysis_"&strSecondCoulmn_AnalysisMetrics
objAnalysisCopy.Cells(1,3)="Reporting_"&strSecondCoulmn_AnalysisMetrics
objAnalysisCopy.Cells(1,4)="Status"
objWorkbook.Save
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
If strAnalysisColumnOrderFlag=False OR strMetricsFlag=False OR strAnalysisColCount=False Then
msgbox "So Data Comparision can not be done"
objWorkbook.Save
objWorkbook.Close
objExcel.Quit
Else
intFalseCount=0
For intAnalysisRow=2 to intAnalysisRowCount
' ------ Get the control of ''Analysis' tab and the string of Aggrecate Keys [strAnalysisAggrData] and respective metrics [strAnalysisMetricsData]
Set objAnalysis=objExcel.Worksheets.Item("Analysis")
' Append all data of each row which is before 'Metrics' column
strAnalysisAggrData=""
For intAnalysisColumn=1 to intMetricAnalysis-1
strAnalysisAggrData=strAnalysisAggrData&"*"&objAnalysis.Cells(intAnalysisRow,intAnalysisColumn)
If(intAnalysisColumn=1) then
strAnalysisAggrData=Replace(strAnalysisAggrData,"*","")
End If
Next
' ' Append all data of each row which is after 'Metrics' column
strAnalysisMetricsData=""
For intFromMetric=intMetricAnalysis+1 to intAnalysisColCount
strAnalysisMetricsData=strAnalysisMetricsData&"*"&objAnalysis.Cells(intAnalysisRow,intFromMetric)
If(intFromMetric=intMetricAnalysis+1 ) then
strAnalysisMetricsData=Replace(strAnalysisMetricsData,"*","")
End If
Next
' ------ Get the control of ''Reporting' tab and the string of Aggrecate Keys [strAnalysisAggrData] and respective metrics [strAnalysisMetricsData]
Set objReporting=objExcel.Worksheets.Item("Reporting")
For intReportingRow=1 to intReportingRowCount
' Append all data of each row which is before 'Metrics' column
strReportingAggrData=""
For intBeforeMetricReporting=1 to intMetricReporting-1
strReportingAggrData=strReportingAggrData&"*"&objReporting.Cells(intReportingRow,intBeforeMetricReporting)
If(intBeforeMetricReporting=1) then
strReportingAggrData=Replace(strReportingAggrData,"*","")
End If
Next
' Append all data of each row which is after 'Metrics' column
strReportingMetricsData=""
For intFromReportingMetric=intMetricReporting+1 to intReportingColCount
strReportingMetricsData=strReportingMetricsData&"*"&objReporting.Cells(intReportingRow,intFromReportingMetric)
If(intFromReportingMetric=intMetricReporting+1 ) then
strReportingMetricsData=Replace(strReportingMetricsData,"*","")
End If
Next
'------------------------------------------------------------ Actual Comparision will be from here ------------------------------------------
If Trim(LCase(strAnalysisAggrData))=Trim(LCase(strReportingAggrData)) Then
objAnalysisCopy.Cells(intAnalysisRow,1)=strAnalysisAggrData
objAnalysisCopy.Cells(intAnalysisRow,2)=strAnalysisMetricsData
objAnalysisCopy.Cells(intAnalysisRow,3)=strReportingMetricsData
'Compare Metrics Data
If Trim(LCase(strAnalysisMetricsData))=Trim(LCase(strReportingMetricsData)) Then
objAnalysisCopy.Cells(intAnalysisRow,4)="PASS"
objAnalysisCopy.Cells(intAnalysisRow,4).font.color=vbGreen
Else
objAnalysisCopy.Cells(intAnalysisRow,4)="FAIL"
intFalseCount=intFalseCount+1
objAnalysisCopy.Cells(intAnalysisRow,4).font.color=vbRed
End If
Exit For
End If
Next
Next
objSummary.Cells(5,2)=intAnalysisRowCount-intReportingRowCount
objSummary.Cells(6,2)=intAnalysisColCount-intReportingColCount
objSummary.Cells(7,2)=intFalseCount
objSummary.Cells(7,2).font.color=vbRed
objWorkbook.Save
objWorkbook.Close
objExcel.Quit
EndTime=Timer()
TotalTime=EndTime-startTime
msgbox "Data Comparision is Completed. Comparision time is "&TotalTime&"Secs"
End If
Use a dictionary and you avoid the nested loops and only scan each sheet once. For example as a VBA macro (untested)
Sub compare()
Dim wb As Workbook
Dim ws(2) As Worksheet, wsSum As Worksheet, wsCopy As Worksheet
Dim rowCount(2) As Long, colCount(2) As Integer, colMetric(2) As Integer
Dim colsMetric(2) As String, colsAll(2) As String, colsKeys(2) As String
Dim bMetricsFlag As Boolean, bColCountFlag As Boolean, bColOrderFlag As Boolean
Dim i As Long, ar, msg As String, intFalseCount As Long
Dim t0 as Single
t0 = Timer
Set wb = ThisWorkbook
Set ws(1) = wb.Sheets("Analysis")
Set ws(2) = wb.Sheets("Reporting")
Set wsSum = wb.Sheets("Summary")
wsSum.Cells.Clear
wsSum.Range("A1:A7") = WorksheetFunction.Transpose(Array("Analysis Row Count", _
"Reporting Row Count", "Analysis Column Count", "Reporting Column Count", _
"Difference of Row Count", "Difference of Column Count", "False Count"))
Set wsCopy = wb.Sheets("Analysis_Copy")
wsCopy.Cells.Clear
' get stats for each sheet 1-Analyis 2=Reporting
For i = 1 To 2
ar = Stats(ws(i))
rowCount(i) = ar(0)
colCount(i) = ar(1)
colMetric(i) = ar(2)
colsAll(i) = ar(3)
colsMetric(i) = ar(4)
colsKeys(i) = ar(5)
Next
' summary
With wsSum
.Cells(1, 2) = rowCount(1)
.Cells(2, 2) = rowCount(2)
.Cells(3, 2) = colCount(1)
.Cells(4, 2) = colCount(2)
End With
' check stats
'Metric' column number must be same
If colMetric(1) = 0 Or colMetric(2) = 0 Or colMetric(1) <> colMetric(2) Then
msg = "Metrics columns not the same or missing : " & vbCr & _
"Analysis : " & colMetric(1) & vbCr & _
"Reporting : " & colMetric(2)
MsgBox msg, vbCritical
bMetricsFlag = False
Else
bMetricsFlag = True
End If
' Verify count of columns
If colCount(1) <> colCount(2) Then
msg = "Column counts not the same : " & vbCr & _
"Analysis : " & colCount(1) & vbCr & _
"Reporting : " & colCount(2)
MsgBox msg, vbCritical
bColCountFlag = False
Else
bColCountFlag = True
End If
'Verify Order of columns
If colsAll(1) <> colsAll(2) Then
msg = "Column order not the same : " & vbCr & _
"Analysis : " & colsAll(1) & vbCr & _
"Reporting : " & colsAll(2)
MsgBox msg, vbCritical
bColOrderFlag = False
Else
bColOrderFlag = True
End If
With wsCopy
.Cells(1, 1) = colsKeys(1)
.Cells(1, 2) = "Analysis_" & colsMetric(1)
.Cells(1, 3) = "Reporting_" & colsMetric(2)
.Cells(1, 4) = "Status"
End With
' checks OK ?
If bColOrderFlag And bMetricsFlag And bColCountFlag Then
' ok
Else
MsgBox "So Data Comparision can not be done", vbCritical
Exit Sub
End If
' start comparison
Dim dict As Object, m As Long, c As Long, s As String
Dim sKey As String, sMetric As String
Set dict = CreateObject("Scripting.Dictionary")
' scan Reporting sheet to build dictionary
m = colMetric(2)
For i = 1 To rowCount(2)
'join cols up to and after metric col
sMetric = "": sKey = ""
For c = 1 To colCount(2)
s = Trim(ws(2).Cells(i, c))
If c < m Then
If sMetric <> "" Then sMetric = sMetric & "*"
sMetric = sMetric & s
ElseIf c > m Then
If sKey <> "" Then sKey = sKey & "*"
sKey = sKey & s
End If
Next
dict(sKey) = sMetric
Next
' scan Analysis sheet to compare dictionary
m = colMetric(1)
For i = 2 To rowCount(1)
'join cols up to and after metric col
sMetric = "": sKey = ""
For c = 1 To colCount(1)
s = Trim(ws(1).Cells(i, c))
If c < m Then
If sMetric <> "" Then sMetric = sMetric & "*"
sMetric = sMetric & s
ElseIf c > m Then
If sKey <> "" Then sKey = sKey & "*"
sKey = sKey & s
End If
Next
' result
wsCopy.Cells(i, 1) = sKey
wsCopy.Cells(i, 2) = sMetric
wsCopy.Cells(i, 3) = dict(sKey)
' pass or fail
If sMetric = dict(sKey) Then
wsCopy.Cells(i, 4) = "PASS"
wsCopy.Cells(i, 4).Font.Color = vbGreen
Else
wsCopy.Cells(i, 4) = "FAIL"
wsCopy.Cells(i, 4).Font.Color = vbRed
intFalseCount = intFalseCount + 1
End If
Next
With wsSum
.Cells(5, 2) = rowCount(1) - rowCount(2)
.Cells(6, 2) = colCount(1) - colCount(2)
.Cells(7, 2) = intFalseCount
.Cells(7, 2).Font.Color = vbRed
End With
MsgBox i - 2 & " rows scanned " & vbCrLf & _
intFalseCount & " FAILED", vbInformation, Int(Timer - t0) & "seconds"
End Sub
Function Stats(ws As Worksheet) As Variant
Dim c As Integer, ar(5) As Variant, s As String
ar(0) = ws.UsedRange.Rows.Count
ar(1) = ws.UsedRange.Columns.Count
ar(2) = 0 'metric column
ar(3) = "" ' col aggregated
ar(4) = "" ' cols upto not including metric
ar(5) = "" ' cols after metric
For c = 1 To ar(1)
s = LCase(Trim(ws.Cells(1, c)))
If s = "metric" Then
ar(2) = c
End If
' aggregate headers before/after metric
If ar(2) = 0 Then
If ar(4) <> "" Then ar(4) = ar(4) & "*"
ar(4) = ar(4) & s
ElseIf c > ar(2) Then
If ar(5) <> "" Then ar(5) = ar(5) & "*"
ar(5) = ar(5) & s
End If
' aggregate all
If ar(3) <> "" Then ar(3) = ar(3) & "*"
ar(3) = ar(3) & s
Next
Stats = ar
End Function
Test data generator
Sub testdata()
Dim ws As Worksheet, n, r, c, ar
ar = Array("", "Analysis", "Reporting")
For n = 1 To 2
Set ws = Sheets(ar(n))
For r = 1 To 30000
For c = 1 To 15
ws.Cells(r, c) = Chr(64 + c) & r & "_abcdefghijklmnopqrstuvwxyz_"
Next
Next
ws.Cells(1, 10) = "metric" ' col J
Next
MsgBox "test data created"
End Sub

For each cell in worksheets("xyz") query

Idea behind the code is that it is supposed to find customer names, then find the level of sales to them throughout the year then paste all this data into another sheet.
Getting a Run-Time error '1004' Application-defined or object-defined error from the following line. I have asterisked the line where I am getting the error.
Sub Import_CustomerData()
Dim strMonth As String
Dim rngMonth As Range
Dim DataImportColum As Integer
Dim DataImportRow As Integer
Dim strFirstCustomer As String
Dim strSecondCustomer As String
Dim strThirdCustomer As String
Dim strFourthCustomer As String
Dim strFifthCustomer As String
Dim lngFirstCustomerSales As Long
Dim lngSecondCustomerSales As Long
Dim lngThirdCustomerSales As Long
Dim lngFourthCustomerSales As Long
Dim lngFifthCustomerSales As Long
Dim lngTotalSales As Long
Dim cell As Range
Dim x As Integer
'Finding Data for clients
For Each cell In Worksheets("Data entry").Range("A1:A99")
If cell.Value = "Customer Sales" Then
strFirstCustomer = cell.Offset(1, 0).Value
strSecondCustomer = cell.Offset(2, 0).Value
strThirdCustomer = cell.Offset(3, 0).Value
strFourthCustomer = cell.Offset(4, 0).Value
strFifthCustomer = cell.Offset(5, 0).Value
End If
Next
'Extracting Data from Customer sheet
***For Each cell In Worksheets("Client_Customer").Range("B83:86")***
'First Customer
If cell.Value = strFirstCustomer Then
lngFirstCustomerSales = Val(cell.Offset(0, 1))
End If
'Second Customer
If cell.Value = strSecondCustomer Then
lngSecondCustomerSales = Val(cell.Offset(0, 1))
End If
'Third Customer
If cell.Value = strThirdCustomer Then
lngThirdCustomerSales = Val(cell.Offset(0, 1))
End If
'Fourth Customer
If cell.Value = strFourthCustomer Then
lngFourthCustomerSales = Val(cell.Offset(0, 1))
End If
'Fifth Customer
If cell.Value = gxdfg Then
lngFifthCustomerSales = Val(cell.Offset(0, 1))
End If
'Total Customers Sales
If cell.Value = "Total:" Then
lngTotalSales = Val(cell.Offset(0, 1))
End If
Next
'Importing it into Data Customer Monthly 2013 sheet.
'Determing month of client system reports
strMonth = Sheets("Client_Customer").Range("B8").Value
If strMonth = "" Then
frmEnter_month.Show
Else
iLenMonth = Len(strMonth)
x = iLenMonth - 5
strLeftMonth = Left(strMonth, x)
End If
'To find Column of Customer imput
For Each cell In Range("B4:M4")
If cell.Value = strLeftMonth Then
DataImportColumn = cell.Column
End If
Next
For Each cell In Worksheets("data customer monthly 2013").Range("A3:A9999")
'First Customer
If cell.Value = strFirstCustomer Then
DataImportRow = cell.Row
** 2 ** lngFirstCustomerSales = Cells(DataImportRow, DataImportColumn).Offset(0, 2).Value ** 2 **
End If
'Second Customer
If cell.Value = strSecondCustomer Then
DataImportRow = cell.Row
lngSecondCustomerSales = Cells(DataImportRow, DataImportColumn).Offset(0, 2).Value
End If
'Third Customer
If cell.Value = strThirdCustomer Then
DataImportRow = cell.Row
lngThirdCustomerSales = Cells(DataImportRow, DataImportColumn).Offset(0, 2).Value
End If
'Fourth customer
If cell.Value = strFourthCustomer Then
DataImportRow = cell.Row
lngFourthCustomerSales = Cells(DataImportRow, DataImportColumn).Offset(0, 2).Value
End If
'Fifth Customer
If cell.Value = strFifthCustomer Then
DataImportRow = cell.Row
lngFifthCustomerSales = Cells(DataImportRow, DataImportColumn).Offset(0, 2).Value
End If
'Total Sales
If cell.Value = "Total Sales" Then
DataImportRow = cell.Row
lngTotalSales = Cells(48, DataImportColumn).Value
End If
Next
DeleteClientSheets
End Sub
Sorry for the large amount of code but does anyone have any suggestions? Couldn't find anything else that help explain the question as cell has been defined as a range.
EDIT1:
Second question: After Silenxor's brilliant solution, I am getting code on the line with the following indicator: ** 2 **
The error I am getting is the same as the first error.
With regards to your asterix line
For Each cell In Worksheets("Client_Customer").Range("B83:86")
Try
For Each cell In Worksheets("Client_Customer").Range("B83:B86")

Resources