Match formula too slow

[mike1984]

Hi all,


I am using a match formula to look at a database of c. 290k rows of data. As such it is very slow, and I was wondering if there was a way to speed it up using VBA.


I have attached a sample which shows my input data and the output matrix I am trying to calculate.


Can someone suggest a way of perhaps replicating my formulas in VBA as it is taking about 3 hours to calculate the formulas and my company won't stump up the money to buy a more powerful machine! :)


Thanks


Mike

[Aflatoon]

If you can sort column A ascending, use this in D3:
=IFERROR(IF(VLOOKUP($C3&">"&D$2,$A$3:$A$89,1)=$C3&">"&D$2,"X",""),"")
and fill across and down.

[p45cal]

I'm wondering whether a pivot table might serve you well.
In the attached I have copied your sheet, but pasted your results matrix as values, just for comparison's sake (and took out the completely blank columns).
Below that I've put in a pivot table based on the data in columns A and B.
Columns A and B were produced from your column A using text-to-columns using the delimiter '>'.
Instead of an 'X' there is a number, being the number of instances of the combination, otherwise the results are exactly the same.
It took me less time to produce the results than it's taken me so far to write this.
Pivot tables are meant to handle the kind of volume of data you have and do it very quickly.

Have I wasted your time?


ps. Do tell others when you cross post where you have done so; http://www.excelforum.com/excel-general/1108142-match-formula-too-slow.html
Why? See http://www.excelguru.ca/content.php?184
(and ExcelForum are quite robust when they discover cross posting without links)

[Paul_Hossler]

A VBA reformat approach. It does assume that the Output sheet has the right set of Departments

Look at the attachment




Option Explicit
Sub FormatData()
Dim wsInput As Worksheet, wsTemp As Worksheet, wsOutput As Worksheet
Dim rInput As Range, rTemp As Range, rOutput As Range, rUnique As Range
Dim rTempNoHeader As Range
Dim aNumbers As Variant, aDepts As Variant
Dim iNumber As Long, iDept As Long, iTemp As Long

Application.ScreenUpdating = False

'init input and output
Set wsInput = ThisWorkbook.Worksheets("Input")
Set rInput = wsInput.Cells(1, 1).CurrentRegion

Set wsOutput = ThisWorkbook.Worksheets("Output")
Set rOutput = wsOutput.Cells(1, 1).CurrentRegion
If rOutput.Rows.Count > 1 Then
rOutput.Cells(2, 1).Resize(rOutput.Rows.Count - 1, 1).EntireRow.Delete
End If

'delete any temp ws and copy input
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Temp").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Call wsInput.Copy(, wsInput)
Set wsTemp = ActiveSheet
wsTemp.Name = "Temp"
Set rTemp = wsTemp.Cells(1, 1).CurrentRegion
Set rTempNoHeader = rTemp.Cells(2, 1).Resize(rTemp.Rows.Count - 1, rTemp.Columns.Count)

'prepare temp, sort, remove dups, split field, create unique list
rTemp.RemoveDuplicates Columns:=1, Header:=xlYes

With wsTemp.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rTempNoHeader
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

rTemp.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=">", FieldInfo:=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True
'get unique list
Call rTemp.Columns(1).Copy(wsTemp.Columns(4))
wsTemp.Columns(4).RemoveDuplicates Columns:=1, Header:=xlYes
Set rUnique = wsTemp.Cells(1, 4).CurrentRegion
Set rUnique = rUnique.Cells(2, 1).Resize(rUnique.Rows.Count, rUnique.Columns.Count)
wsTemp.Cells(1, 1).Value = "Number"
wsTemp.Cells(1, 2).Value = "Department"
wsTemp.Cells(1, 4).Value = "Unique"

'put on output
Call rUnique.Copy(wsOutput.Cells(2, 1))
Set rOutput = wsOutput.Cells(1, 1).CurrentRegion

'in to array, transpose to have 1 dim array
With Application.WorksheetFunction
aNumbers = .Transpose(rOutput.Columns(1))
aDepts = .Transpose(.Transpose(rOutput.Rows(1)))
End With


With rTemp
For iTemp = 2 To .Rows.Count
iNumber = 0
iDept = 0

Application.StatusBar = .Cells(iTemp, 1).Value & " -- " & .Cells(iTemp, 2).Value & _
Format(iTemp / .Rows.Count, "#0.0%")


On Error Resume Next
iNumber = Application.WorksheetFunction.Match(.Cells(iTemp, 1).Value, aNumbers, 0)
iDept = Application.WorksheetFunction.Match(.Cells(iTemp, 2).Value, aDepts, 0)
On Error GoTo 0

If iNumber > 0 And iDept > 0 Then
rOutput.Cells(iNumber, iDept).Value = "X"
End If
Next iTemp
End With


'delete temp
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Temp").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Application.StatusBar = False
Application.ScreenUpdating = True


End Sub