Large Spreadsheet, VBA code is hanging.

[H82BL8]

Hello,

I have a large, 45 tab spreadsheet which the current code appears to be hanging, or at least is taking a very long time to run (even left overnight to no avail).

The spreadsheet consists of the first tab, Location_Summary (an 11,000 list of part numbers) with the subsequent tabs being area locations within a warehouse.

Each area location tab has part numbers listed in column A. Many part numbers are located in various areas.

On the Location_Summary tab, I am trying to return into column C (Sheet Names) the tab name/s where each part number shows up.Attached is a snip of the Location_Summary tab.

​

Hoping someone can offer advice how to improve the following code as it is not working, even when left as the only thing running over night.

Sub test()
Dim a, i As Long, ws As Worksheet, r As Range
With Sheets("Location_Summary").Cells(1).CurrentRegion
.Columns(3).Offset(1).ClearContents
a = .Value
For Each ws In Worksheets
If ws.Name <> "Location_Summary" Then
For i = 2 To UBound(a, 1)
Set r = ws.Columns(1).Find(a(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not r Is Nothing Then
a(i, 3) = a(i, 3) & IIf(a(i, 3) <> "", ", ", "") & ws.Name
End If
Next
End If
Next
.Resize(, 3).Value = a
End With
End Sub

Thank you in advance.

 

[JoeMo]

Not clear why it should take so long. Can you post the layout of Location_Summary with some sample data that can be copied from a browser using one of the tools in the link below?

https://www.mrexcel.com/forum/about-board/508133-attachments.html

 

[Norie]

You should ditch Find. and as well as putting the values from column A of 'Location Summary' in an array put the values from column A of the other sheets into arrays.

Perhaps something like this which assumes the part numbers on all sheets are of the same data type.

Sub FindPartNos()
Dim ws As Worksheet
Dim arrFound As Variant
Dim arrParts As Variant
Dim arrSheets As Variant
Dim arrSummary As Variant
Dim dicParts As Object
Dim cnt As Long
Dim I As Long
Dim Res As Variant
Dim ky As Variant

    Set dicParts = CreateObject("Scripting.Dictionary")
    
    arrSummary = Worksheets("Location Summary").Range("A1").CurrentRegion.Columns(1).Value
    
    ReDim arrFound(LBound(arrSummary, 1) To UBound(arrSummary, 1), 1 To 1)
    
    For Each ws In Worksheets
        If ws.Name <> "Location Summary" Then
            dicParts(ws.Name) = ws.Range("A1").CurrentRegion.Columns(1).Value
        End If
    Next ws
    
    For I = LBound(arrSummary, 1) + 1 To UBound(arrSummary, 1)
        ReDim arrSheets(1 To Worksheets.Count)
        cnt = 0
        For Each ky In dicParts
        
            arrParts = dicParts(ky)
            Res = Application.Match(arrSummary(I, 1), arrParts, 0)
            If Not IsError(Res) Then
                cnt = cnt + 1
                arrSheets(cnt) = ky
            End If
            
        Next ky
        
        If cnt > 0 Then
            ReDim Preserve arrSheets(1 To cnt)
            arrFound(I, 1) = Join(arrSheets, ",")
        End If
        
        Erase arrSheets
        
    Next I
    
    Sheets("Location Summary").Range("C1").Resize(UBound(arrFound, 1)).Value = arrFound
    
End Sub

 

[H82BL8]

Hi Joe,

Thanks for your reply. Below should be a screen shot of the Location_Summary tab as requested. I am trying to return the various tab names, (showing each appearance of particular Part Number within the spreadsheet), into colun C - Sheet Names.

<a target="_blank" href="https://imageshack.com/i/po4SLhpEp"><img src="https://imagizer.imageshack.com/v2/xq90/924/4SLhpE.png" border="0"></a>

Thanks very much.

 

[Fazza]

you might consider another approach

11,000 records, 45 worksheets.

This looks like a simple & suitable job for a database. And not a suitable job for a spreadsheet.

Or if you were stuck with users needing to use Excel, make Excel a front end to data in an mdb file. This can be done without having MS Access installed.