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-gene...-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