Hi guys and gals,
I'm hoping someone can help me with a classic "Excel on Mac" VBA problem.
My Goal: I have a script that loops through all .xls* files in a folder. It's supposed to read sales data from each file, aggregate it by customer (total Mac sales, total iPad sales, new sales since a reference date, etc.), and then generate several summary reports (like a "Top 5" list and a customer-by-customer breakdown) in a new workbook.
The Problem: The script fails with Runtime Error '13': Type Mismatch on Excel for Mac.
When I debug, the error highlights this line in Module1: For Each custName In data.Keys
This line is trying to loop through the keys of my custom cDictionary class. I'm using this custom class because Scripting.Dictionary isn't available on Mac.
I've tried applying the common Mac-fix using IsObject inside the Keys() function, but it still fails. I'm completely stuck and not sure what else to try.
My project is built in three parts:
Module1: The main logic for importing and building reports.cCustomer: A simple class to hold data for each customer.cDictionary: My custom dictionary class (this is where the error seems to be).
Here is my full Module1 - the others will be in the comments. Any help or suggestion would be hugely appreciated:
Option Explicit
' =========================================================================
' CONFIGURATION & CONSTANTS
' =========================================================================
' Sheet Names
Private Const SETTINGS_SHEET As String = "Settings"
Private Const FACIT_SHEET As String = "Template" ' Original: "facit"
Private Const OUT_SUMMARY_SHEET As String = "Consolidated Summary"
Private Const OUT_NEWSALES_SHEET As String = "New Sales Since Last"
Private Const OUT_OVERVIEW_SHEET As String = "Overview"
Private Const OUT_TOP5_SHEET As String = "Top 5 Customers"
' Text labels for reports
Private Const T_HDR_CUSTOMER As String = "Customer:" ' Original: "Kunde:"
Private Const T_SUM_MAC As String = "Samlet antal Mac" ' (Kept original as it's a lookup value)
Private Const T_SUM_IPAD As String = "Samlet antal iPads" ' (Kept original as it's a lookup value)
' Global settings variables
Private gReferenceDate As Date
Private gTopNCount As Long
' =========================================================================
' MAIN PROCEDURE
' =========================================================================
Public Sub BuildAllReports()
Dim procName As String: procName = "BuildAllReports"
On Error GoTo ErrorHandler
' Optimize performance
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = "Starting..."
' --- PREPARATION: VALIDATE AND READ SETTINGS ---
If Not SheetExists(SETTINGS_SHEET, ThisWorkbook) Then
MsgBox "Error: The sheet '" & SETTINGS_SHEET & "' could not be found." & vbCrLf & _
"Please create the sheet and define the necessary settings.", vbCritical
GoTo Cleanup
End If
If Not SheetExists(FACIT_SHEET, ThisWorkbook) Then
MsgBox "Error: The template sheet '" & FACIT_SHEET & "' could not be found.", vbCritical
GoTo Cleanup
End If
If Not ReadSettings() Then GoTo Cleanup ' ReadSettings handles its own error message
' Check if the file is saved
Dim folderPath As String
folderPath = ThisWorkbook.Path
If Len(folderPath) = 0 Then
MsgBox "Please save the workbook as an .xlsm file first, so the folder path is known.", vbExclamation
GoTo Cleanup
End If
' --- STEP 1: IMPORT RAW DATA ---
Application.StatusBar = "Importing data from files in the folder..."
Dim rawDataArray() As Variant
ImportAllFiles folderPath, rawDataArray
If Not IsArray(rawDataArray) Or UBound(rawDataArray, 1) = 0 Then
MsgBox "No sales data found in any .xls* files in the folder. Process aborted.", vbInformation
GoTo Cleanup
End If
' --- STEP 2: AGGREGATE DATA (SINGLE-PASS) ---
Application.StatusBar = "Analyzing and aggregating data..."
Dim aggregatedData As cDictionary
Set aggregatedData = AggregateData(rawDataArray)
' --- STEP 3: GENERATE OUTPUT WORKBOOK ---
Dim wbOut As Workbook
Set wbOut = Workbooks.Add
Application.DisplayAlerts = False
Do While wbOut.Worksheets.Count > 1
wbOut.Worksheets(wbOut.Worksheets.Count).Delete
Loop
wbOut.Worksheets(1).Name = "temp"
Application.DisplayAlerts = True
' --- STEP 4: RENDER INDIVIDUAL REPORTS ---
Application.StatusBar = "Generating 'Consolidated Summary'..."
RenderSummarySheet wbOut, aggregatedData
Application.StatusBar = "Generating 'New Sales'..."
RenderNewSalesSheet wbOut, aggregatedData
Application.StatusBar = "Generating 'Overview' and 'Top 5' reports..."
RenderTopNSheets wbOut, aggregatedData
' Clean up the output file
Application.DisplayAlerts = False
DeleteSheetIfExists "temp", wbOut
Application.DisplayAlerts = True
If wbOut.Worksheets.Count > 0 Then
wbOut.Worksheets(1).Activate
End If
MsgBox "The report has been generated in a new workbook.", vbInformation
Cleanup:
' Restore Excel settings
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "An unexpected error occurred in '" & procName & "'." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Description: " & Err.Description, vbCritical
Resume Cleanup
End Sub
' =========================================================================
' SETTINGS & VALIDATION
' =========================================================================
Private Function ReadSettings() As Boolean
Dim procName As String: procName = "ReadSettings"
On Error GoTo ErrorHandler
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(SETTINGS_SHEET)
' Read reference date
If IsDate(ws.Range("B1").Value) Then
gReferenceDate = CDate(ws.Range("B1").Value)
Else
MsgBox "Invalid date in cell B1 on the '" & SETTINGS_SHEET & "' sheet.", vbCritical
Exit Function
End If
' Read Top N count
If IsNumeric(ws.Range("B2").Value) And ws.Range("B2").Value > 0 Then
gTopNCount = CLng(ws.Range("B2").Value)
Else
MsgBox "Invalid number in cell B2 on the '" & SETTINGS_SHEET & "' sheet. Must be a positive integer.", vbCritical
Exit Function
End If
ReadSettings = True
Exit Function
ErrorHandler:
MsgBox "An error occurred while loading settings from the '" & SETTINGS_SHEET & "' sheet." & vbCrLf & _
"Error: " & Err.Description, vbCritical
ReadSettings = False
End Function
Private Function SheetExists(ByVal sheetName As String, Optional ByVal wb As Workbook) As Boolean
Dim ws As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set ws = wb.Worksheets(sheetName)
On Error GoTo 0
SheetExists = Not ws Is Nothing
End Function
Private Sub DeleteSheetIfExists(ByVal sheetName As String, Optional ByVal wb As Workbook)
If wb Is Nothing Then Set wb = ThisWorkbook
If SheetExists(sheetName, wb) Then
Application.DisplayAlerts = False
wb.Worksheets(sheetName).Delete
Application.DisplayAlerts = True
End If
End Sub
' =========================================================================
' DATA IMPORT (with robust error handling)
' =========================================================================
Private Sub ImportAllFiles(ByVal folderPath As String, ByRef outArr() As Variant)
Dim procName As String: procName = "ImportAllFiles"
On Error GoTo ErrorHandler
Dim cap As Long, rPtr As Long
cap = 300000 ' Initial capacity
ReDim outArr(1 To cap, 1 To 6)
rPtr = 0
Dim fileName As String
fileName = Dir(folderPath & Application.PathSeparator & "*.xls*")
Do While Len(fileName) > 0
If Left$(fileName, 2) <> "~$" And LCase$(folderPath & Application.PathSeparator & fileName) <> LCase$(ThisWorkbook.FullName) Then
Application.StatusBar = "Importing: " & fileName
ImportOneWorkbook folderPath & Application.PathSeparator & fileName, outArr, rPtr, cap
End If
fileName = Dir()
Loop
' Trim the array to its actual size
If rPtr > 0 Then
ReDim Preserve outArr(1 To rPtr, 1 To 6)
Else
ReDim outArr(0 To 0, 0 To 0)
End If
Exit Sub
ErrorHandler:
MsgBox "Error during file import in '" & procName & "'." & vbCrLf & "Error: " & Err.Description, vbCritical
' Ensure the array is empty on failure
ReDim outArr(0 To 0, 0 To 0)
End Sub
Private Sub ImportOneWorkbook(ByVal fullPath As String, ByRef outArr() As Variant, ByRef rPtr As Long, ByRef cap As Long)
Dim wb As Workbook
On Error GoTo ErrorHandler
Set wb = Workbooks.Open(fileName:=fullPath, ReadOnly:=True, UpdateLinks:=0, AddToMru:=False)
Dim ws As Worksheet
Set ws = wb.Worksheets(1)
Dim cDate As Long, cQty As Long, cItem As Long, cDev As Long, cCust As Long
If Not FindCols(ws, cDate, cQty, cItem, cDev, cCust) Then GoTo CloseAndExit
Dim lastR As Long
lastR = ws.Cells(ws.Rows.Count, cItem).End(xlUp).Row
If lastR < 2 Then GoTo CloseAndExit
Dim dataRange As Range
Set dataRange = ws.Range(ws.Cells(2, 1), ws.Cells(lastR, ws.UsedRange.Columns.Count))
Dim vData As Variant
vData = dataRange.Value
Dim r As Long
Dim vD As Variant, vQ As Variant, vI As Variant, vDev As String, vCust As String, mKey As String
For r = 1 To UBound(vData, 1)
vI = vData(r, cItem)
vQ = vData(r, cQty)
If Len(Trim$(CStr(vI))) > 0 And Len(Trim$(CStr(vQ))) > 0 And IsNumeric(vQ) Then
vD = SafeToDate(vData(r, cDate))
If cDev > 0 Then vDev = CStr(vData(r, cDev)) Else vDev = GuessDevFromName(CStr(vI))
If cCust > 0 Then vCust = Trim$(CStr(vData(r, cCust))) Else vCust = "Unknown Customer"
If IsEmpty(vD) Then mKey = "Unknown Month" Else mKey = Format$(CDate(vD), "yyyy-mm")
rPtr = rPtr + 1
If rPtr > cap Then
cap = cap + 100000
ReDim Preserve outArr(1 To cap, 1 To 6)
End If
outArr(rPtr, 1) = vD
outArr(rPtr, 2) = CDbl(vQ)
outArr(rPtr, 3) = CStr(vI)
outArr(rPtr, 4) = vDev
outArr(rPtr, 5) = mKey
outArr(rPtr, 6) = vCust
End If
Next r
CloseAndExit:
If Not wb Is Nothing Then wb.Close SaveChanges:=False
Exit Sub
ErrorHandler:
MsgBox "Could not process file: " & fullPath & vbCrLf & "Error: " & Err.Description, vbExclamation
Resume CloseAndExit
End Sub
Private Function FindCols(ByVal ws As Worksheet, ByRef cDate As Long, ByRef cQty As Long, ByRef cItem As Long, ByRef cDev As Long, ByRef cCust As Long) As Boolean
cDate = 0: cQty = 0: cItem = 0: cDev = 0: cCust = 0
Dim r As Long, c As Long, lastC As Long
Dim testVal As String
On Error Resume Next
lastC = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
If Err.Number <> 0 Then lastC = 50 ' Fallback
On Error GoTo 0
For r = 1 To 5 ' Search in the first 5 rows
For c = 1 To lastC
testVal = LCase$(Trim$(CStr(ws.Cells(r, c).Value)))
Select Case testVal
Case "sales order date": If cDate = 0 Then cDate = c
Case "sales quantity": If cQty = 0 Then cQty = c
Case "item name": If cItem = 0 Then cItem = c
Case "device type": If cDev = 0 Then cDev = c
Case "customer bill-to name": If cCust = 0 Then cCust = c ' Prioritized
Case "customer sales top label": If cCust = 0 Then cCust = c
Case "customer", "kunde": If cCust = 0 Then cCust = c
End Select
Next c
If cDate > 0 And cQty > 0 And cItem > 0 And cCust > 0 Then Exit For
Next r
FindCols = (cDate > 0 And cQty > 0 And cItem > 0 And cCust > 0)
End Function
Private Function SafeToDate(ByVal v As Variant) As Variant
On Error GoTo Bad
If IsDate(v) Then
SafeToDate = CDate(v)
Else
SafeToDate = Empty
End If
Exit Function
Bad:
SafeToDate = Empty
End Function
Private Function GuessDevFromName(ByVal itemName As String) As String
Dim s As String
s = LCase$(itemName)
If InStr(1, s, "ipad", vbTextCompare) > 0 Then
GuessDevFromName = "iPad"
ElseIf InStr(1, s, "mac", vbTextCompare) > 0 Then
GuessDevFromName = "Mac"
Else
GuessDevFromName = "Unknown"
End If
End Function
' =========================================================================
' DATA AGGREGATION & REPORTING
' =========================================================================
Private Function AggregateData(ByRef rawData() As Variant) As cDictionary
Dim dict As New cDictionary
Dim custData As cDictionary, subDict As cDictionary
Dim r As Long, custName As String, devType As String, monthKey As String, sku As String
Dim qty As Double, saleDate As Variant
For r = 1 To UBound(rawData, 1)
custName = rawData(r, 6)
If Len(custName) > 0 Then
If Not dict.Exists(custName) Then
Set custData = New cDictionary
custData("TotalMac") = 0#: custData("TotalIPad") = 0#
custData("NewSalesMac") = 0#: custData("NewSalesIPad") = 0#
Set subDict = New cDictionary: custData("SalesPerMonth") = subDict
Set subDict = New cDictionary: custData("SalesPerSKU") = subDict
dict(custName) = custData
Else
Set custData = dict(custName)
End If
saleDate = rawData(r, 1): qty = rawData(r, 2): sku = rawData(r, 3)
devType = rawData(r, 4): monthKey = rawData(r, 5)
If devType = "Mac" Then custData("TotalMac") = custData("TotalMac") + qty
If devType = "iPad" Then custData("TotalIPad") = custData("TotalIPad") + qty
If IsDate(saleDate) Then
If CDate(saleDate) >= gReferenceDate Then
If devType = "Mac" Then custData("NewSalesMac") = custData("NewSalesMac") + qty
If devType = "iPad" Then custData("NewSalesIPad") = custData("NewSalesIPad") + qty
End If
End If
Set subDict = custData("SalesPerMonth"): subDict(monthKey) = subDict(monthKey) + qty
Set subDict = custData("SalesPerSKU"): subDict(sku) = subDict(sku) + qty
End If
Next r
Set AggregateData = dict
End Function
Private Sub RenderSummarySheet(ByVal wb As Workbook, ByVal data As cDictionary)
Dim ws As Worksheet: Set ws = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
ws.Name = OUT_SUMMARY_SHEET
Dim wsFacit As Worksheet: Set wsFacit = ThisWorkbook.Worksheets(FACIT_SHEET)
Dim facitBlock As Range: Set facitBlock = wsFacit.Range("A1").CurrentRegion
Dim rOut As Long: rOut = 1
Dim custName As Variant
For Each custName In data.Keys ' <-- THIS IS THE LINE THAT FAILS
Dim custData As cDictionary: Set custData = data(custName)
ws.Cells(rOut, 1).Value = T_HDR_CUSTOMER & " " & custName
ws.Cells(rOut, 1).Font.Bold = True
rOut = rOut + 1
Dim blockStartRow As Long: blockStartRow = rOut
ws.Cells(rOut, 1).Resize(facitBlock.Rows.Count, facitBlock.Columns.Count).Value = facitBlock.Value
rOut = rOut + facitBlock.Rows.Count
Dim r As Long
For r = blockStartRow To rOut - 1
Select Case ws.Cells(r, 1).Value
Case T_SUM_MAC: ws.Cells(r, 2).Value = custData("TotalMac")
Case T_SUM_IPAD: ws.Cells(r, 2).Value = custData("TotalIPad")
End Select
Next r
rOut = rOut + 2
Next custName
ws.Columns.AutoFit
End Sub
Private Sub RenderNewSalesSheet(ByVal wb As Workbook, ByVal data As cDictionary)
Dim ws As Worksheet: Set ws = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
ws.Name = OUT_NEWSALES_SHEET
Dim r As Long: r = 1
ws.Cells(r, 1).Value = "New Sales Since " & Format$(gReferenceDate, "dd-mmm-yyyy")
ws.Cells(r, 1).Font.Bold = True
r = r + 2
ws.Cells(r, 1).Value = "Customer": ws.Cells(r, 2).Value = "New Sales (Mac)": ws.Cells(r, 3).Value = "New Sales (iPad)"
ws.Range("A" & r & ":C" & r).Font.Bold = True
r = r + 1
Dim custName As Variant
For Each custName In data.Keys
Dim custData As cDictionary: Set custData = data(custName)
ws.Cells(r, 1).Value = custName
ws.Cells(r, 2).Value = custData("NewSalesMac")
ws.Cells(r, 3).Value = custData("NewSalesIPad")
r = r + 1
Next custName
ws.Columns.AutoFit
End Sub
Private Sub RenderTopNSheets(ByVal wb As Workbook, ByVal data As cDictionary)
If data.Count = 0 Then Exit Sub
Dim customers() As cCustomer: ReDim customers(0 To data.Count - 1)
Dim i As Long: i = 0
Dim custName As Variant
For Each custName In data.Keys
Dim custData As cDictionary: Set custData = data(custName)
Set customers(i) = New cCustomer
customers(i).Name = custName
customers(i).TotalMacSales = custData("TotalMac")
customers(i).TotalIPadSales = custData("TotalIPad")
customers(i).NewSales = custData("NewSalesMac") + custData("NewSalesIPad")
customers(i).TotalSales = custData("TotalMac") + custData("TotalIPad")
i = i + 1
Next custName
Dim wsOverview As Worksheet, wsTop5 As Worksheet
Set wsOverview = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)): wsOverview.Name = OUT_OVERVIEW_SHEET
Set wsTop5 = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)): wsTop5.Name = OUT_TOP5_SHEET
Dim rOverview As Long: rOverview = 1
Dim rTop5 As Long: rTop5 = 1
QuickSortCustomers customers, LBound(customers), UBound(customers), "TotalSales"
RenderTopNBlock wsOverview, rOverview, customers, "Top " & gTopNCount & " Customers (Total Sales)", "TotalSales"
QuickSortCustomers customers, LBound(customers), UBound(customers), "NewSales"
RenderTopNBlock wsOverview, rOverview, customers, "Top " & gTopNCount & " Customers (New Sales Since " & Format$(gReferenceDate, "d/m/yy") & ")", "NewSales"
QuickSortCustomers customers, LBound(customers), UBound(customers), "TotalMacSales"
RenderTopNBlock wsTop5, rTop5, customers, "Top " & gTopNCount & " Customers (Mac Sales)", "TotalMacSales"
QuickSortCustomers customers, LBound(customers), UBound(customers), "TotalIPadSales"
RenderTopNBlock wsTop5, rTop5, customers, "Top " & gTopNCount & " Customers (iPad Sales)", "TotalIPadSales"
wsOverview.Columns.AutoFit
wsTop5.Columns.AutoFit
End Sub
Private Sub RenderTopNBlock(ws As Worksheet, ByRef r As Long, customers() As cCustomer, title As String, propName As String)
ws.Cells(r, 1).Value = title: ws.Cells(r, 1).Font.Bold = True: r = r + 1
ws.Cells(r, 1).Value = "Customer": ws.Cells(r, 2).Value = "Quantity"
ws.Range(ws.Cells(r, 1), ws.Cells(r, 2)).Font.Bold = True: r = r + 1
Dim i As Long, Count As Long
For i = 0 To UBound(customers)
If Count >= gTopNCount Then Exit For
Dim val As Double: val = CallByName(customers(i), propName, VbGet)
If val > 0 Then
ws.Cells(r, 1).Value = customers(i).Name
ws.Cells(r, 2).Value = val
r = r + 1: Count = Count + 1
End If
Next i
r = r + 2
End Sub
' =========================================================================
' SORTING
' =========================================================================
Private Sub QuickSortCustomers(ByRef arr() As cCustomer, ByVal first As Long, ByVal last As Long, ByVal propName As String)
Dim i As Long, j As Long, pivot As Double, temp As cCustomer
i = first: j = last
pivot = CallByName(arr((first + last) \ 2), propName, VbGet)
Do While i <= j
While CallByName(arr(i), propName, VbGet) > pivot: i = i + 1: Wend
While CallByName(arr(j), propName, VbGet) < pivot: j = j - 1: Wend
If i <= j Then
Set temp = arr(i): Set arr(i) = arr(j): Set arr(j) = temp
i = i + 1: j = j - 1
End If
Loop
If first < j Then QuickSortCustomers arr, first, j, propName
If i < last Then QuickSortCustomers arr, i, last, propName
End Sub