Help Required to make code run faster

[Poundland]

Hi Guys,

I once again call upon your collective wisdom.

I have written some code, below, which runs through a sheet and looking at whether or not an Item has a number of a blank cell assigned to it, it then pulls out the relative data and places it into another sheet.

There are many different combinations to review and normally results in excess of 80k records being picked up.

The issue is that currently is it taking almost 2 hours for the code to run through, and I want to try and speed it up, is there a way that I can do this?


I know that I have a status bar update as part of the code, and by eliminating this I would save some time, but that is a miniscule saving compared to the overall run time.

I have attached the file also to review.

Sub newresults()
Application.ScreenUpdating = False
Dim Destn As Range, Allsheet As Worksheet, MScll As Range, Storecll As String, MScount As Range, Storecount As Range, sls As Range
Dim col As Integer, rw As Integer
Set Destn = Sheets("Results").Cells(2, 1)
Set Allsheet = Sheets("All")
rw = 5
For Each Storecount In Allsheet.Range(Allsheet.Cells(6, 1), Allsheet.Cells(6, 1).End(xlDown)).Cells
Set storecell = Storecount
rw = rw + 1
col = 2
For Each MScount In Allsheet.Range(Allsheet.Cells(5, 2), Allsheet.Cells(5, 2).End(xlToRight)).Cells
Set MScll = MScount
Set sls = Allsheet.Range(Allsheet.Cells(rw, col), Allsheet.Cells(rw, col)).Cells
col = col + 1
If sls = 0 Then
storecell.Copy Destn
Set Destn = Destn.Offset(0, 1)
MScll.Copy Destn
Set Destn = Destn.Offset(1, -1)
Application.StatusBar = Destn.Address
DoEvents
Else
End If
Next MScount
Next Storecount
Application.ScreenUpdating = True
Sheets("Results").Select
End Sub

[Paul_Hossler]

Really not clear to me what you're looking for, but this does run faster at least. I guessed that you were looking for the Store and the Bxxxx to be listed if the intersection was blank (marked in red)

Parts of the results are on the 'Results' worksheet in the attachment. I deleted large pieces of the input and the output sheets to be able to upload

Sub AnotherWay()
    Dim wsDestn As Worksheet, wsAllsheet As Worksheet
    Dim rData As Range, rBlanks As Range, rBlankCell As Range
    Dim iLineOut  As Long
    
    'init config
    Application.ScreenUpdating = False
    
    'init sheets
    Set wsAllsheet = Worksheets("All")
    Set wsDestn = Worksheets("Results")
    'all data first
    Set rData = wsAllsheet.Cells(1, 1).CurrentRegion
    'lose first 5 and last row
    Set rData = rData.Cells(6, 1).Resize(rData.Rows.Count - 6, rData.Columns.Count)
    
    'just blank cells
    Set rBlanks = rData.SpecialCells(xlCellTypeBlanks)
    
    iLineOut = 2
    
    'loop the blanks
    For Each rBlankCell In rBlanks.Cells
        Application.StatusBar = "#:" & (iLineOut - 1) & "  Addr:" & rBlankCell.Address
        wsDestn.Cells(iLineOut, 1).Value = rBlankCell.EntireRow.Cells(1, 1).Value
        wsDestn.Cells(iLineOut, 2).Value = rBlankCell.EntireColumn.Cells(5, 1).Value
        iLineOut = iLineOut + 1
    
        If iLineOut Mod 1000 = 0 Then DoEvents
    
    Next
    wsDestn.Select
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
End Sub

[SamT]

This compile. Unfortunately, I don't have time to test it. When corrected so it works, it will be extremely fast.

Sub newresult_VBAX_SamT()
Dim rData As Range
Dim AllData As Variant
Dim ResultData()
Dim ResultRows As Long
Dim i As Long, j As Long, k As Long

    Set rData = Worksheets("All").Cells(1, 1).CurrentRegion
     'lose first 5 and last row
    Set rData = rData.Cells(6, 1).Resize(rData.Rows.Count - 6, rData.Columns.Count)

  AllData = rData
  i = UBound(AllData(1))
  j = UBound(AllData(2))
  ReDim ResultData(i, j)
  
  For i = 1 To i
    For j = 1 To j
      If AllData(i, j) = "" Then
        ResultData(k, 1) = AllData(i, 1)
        ResultData(k, 2) = AllData(0, j)
        k = k + 1
      End If
    Next
  Next
  
  ReDim Preserve ResultData(k + 1, 2)
  
  Worksheets("Results").Range("A2").Resize(k + 2, 2) = ResultData
  
End Sub

[snb]

probably faster:

Sub M_snb()
   Sheets("all").Cells(4, 2) = ""
   sn = Sheets("all").Cells(5, 1).CurrentRegion
   ReDim sp(Sheets("all").Cells(5, 1).CurrentRegion.SpecialCells(4).Count, 1)
   
   For j = 2 To UBound(sn)
      For jj = 2 To UBound(sn, 2)
        If sn(j, jj) = "" Then
           sp(jjj, 0) = sn(j, 1)
           sp(jjj, 1) = sn(1, jj)
           jjj = jjj + 1
        End If
      Next
    Next
    
    Sheets("Results").Cells(1).Resize(UBound(sp) + 1, 2) = sp
End Sub

[Poundland]

Really not clear to me what you're looking for, but this does run faster at least. I guessed that you were looking for the Store and the Bxxxx to be listed if the intersection was blank (marked in red)

Parts of the results are on the 'Results' worksheet in the attachment. I deleted large pieces of the input and the output sheets to be able to upload

Sub AnotherWay()
    Dim wsDestn As Worksheet, wsAllsheet As Worksheet
    Dim rData As Range, rBlanks As Range, rBlankCell As Range
    Dim iLineOut  As Long
    
    'init config
    Application.ScreenUpdating = False
    
    'init sheets
    Set wsAllsheet = Worksheets("All")
    Set wsDestn = Worksheets("Results")
    'all data first
    Set rData = wsAllsheet.Cells(1, 1).CurrentRegion
    'lose first 5 and last row
    Set rData = rData.Cells(6, 1).Resize(rData.Rows.Count - 6, rData.Columns.Count)
    
    'just blank cells
    Set rBlanks = rData.SpecialCells(xlCellTypeBlanks)
    
    iLineOut = 2
    
    'loop the blanks
    For Each rBlankCell In rBlanks.Cells
        Application.StatusBar = "#:" & (iLineOut - 1) & "  Addr:" & rBlankCell.Address
        wsDestn.Cells(iLineOut, 1).Value = rBlankCell.EntireRow.Cells(1, 1).Value
        wsDestn.Cells(iLineOut, 2).Value = rBlankCell.EntireColumn.Cells(5, 1).Value
        iLineOut = iLineOut + 1
    
        If iLineOut Mod 1000 = 0 Then DoEvents
    
    Next
    wsDestn.Select
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
End Sub

Paul,

This is exactly what I was looking for, process now runs through in less than 5 minutes, and picks up every blank cell and corresponding Store and Item description.

I am familiar with most of the functions you have used but have never combined them in that manner, for instance capturing the descriptions using the Entire Row and Entire Column functions.

One function you have used I have not seen before, Mod, what does this do in your code?

[Poundland]

probably faster:

Sub M_snb()
   Sheets("all").Cells(4, 2) = ""
   sn = Sheets("all").Cells(5, 1).CurrentRegion
   ReDim sp(Sheets("all").Cells(5, 1).CurrentRegion.SpecialCells(4).Count, 1)
   
   For j = 2 To UBound(sn)
      For jj = 2 To UBound(sn, 2)
        If sn(j, jj) = "" Then
           sp(jjj, 0) = sn(j, 1)
           sp(jjj, 1) = sn(1, jj)
           jjj = jjj + 1
        End If
      Next
    Next
    
    Sheets("Results").Cells(1).Resize(UBound(sp) + 1, 2) = sp
End Sub

Thank you for your time, unfortunately this code, whilst identifying every blank cell, only picks up the value in Sheets("All").cells(3,1) and puts this into the Results sheet for each entry.

[snb]

Please do not quote !

You are mistaken.
My code writes the 'rowlabel' (store description) and the 'columnlabel' (item description) of every empty cell into the sheet 'results' in 6 seconds.

You must have applied my code to another file than the one you posted.
Essential is the removing of every value in the row just above the itemnames. Otherwise the 'currentregion' isn't correct.

[Poundland]

snb, thank you for your response, you did not mention on the original post that I had to remove all data above the currentregion, so I guess that is why the code did not work, it did run through ultra quickly, granted, but it did only pick up the one cell value and I was using it on the correct file, but as I said I guess it did not work as I had not cleared the data from the above the currentregion.

Unfortunately I need the data above the currentregion as I use this in some VBA code before I search for the blanks, so your code would not work for me, maybe I should have mentioned this on my original post, an oversight on my part, but again thank you for your time.

[Poundland]

snb, when I remove the data above the current region, to test your code, it does indeed do what you said it does, and on my full data set runs in less than 10 seconds.

My full dataset has over 90k blank cells.

[snb]

If your dataset is starting in row 5 you can use:

Sub M_snb() 
    Sheets("all").rows(4).clearcontents

 
    sn = Sheets("all").Cells(5, 1).CurrentRegion 
    ReDim sp(Sheets("all").Cells(5, 1).CurrentRegion.SpecialCells(4).Count, 1) 
     
    For j = 2 To UBound(sn) 
        For jj = 2 To UBound(sn, 2) 
            If sn(j, jj) = "" Then 
                sp(jjj, 0) = sn(j, 1) 
                sp(jjj, 1) = sn(1, jj) 
                jjj = jjj + 1 
            End If 
        Next 
    Next 
     
    Sheets("Results").Cells(1).Resize(UBound(sp) + 1, 2) = sp 
End Sub

[Poundland]

snb, thank you for your response, with a slight modification to where the collected data is placed on the Results sheet, your code now works perfectly and is indeed very quick.

I only modified the last code line as below;

Sheets("Results").Cells(2, 1).Resize(UBound(sp) + 1, 2) = sp

I have already given my one day allowance on reputation to Paul, so I will come back tomorrow and add to your reputation.

Thank you again to both yourself and Paul for your help. Much appreciated.

[snb]

from > 2 hours to < 10 seconds....

[Paul_Hossler]

I am familiar with most of the functions you have used but have never combined them in that manner, for instance capturing the descriptions using the Entire Row and Entire Column functions.

One function you have used I have not seen before, Mod, what does this do in your code?

The first part returns a range object with just the blank cells (.SpecialCells) in the .Resize data area

The For Each rBlankCell of the range containing blanks just loops through each cell of the blanks (e.g. Z123) or a single cell, not every cell in every row in every column

Since you wanted the first column of that .EntireRow (e.g. 123) or A123 and the 6th row of that .EntireColumn (e.g. Z) or Z6 they come together


The iLineOut Mod 1000 was just to call DoEvents every 1000th time instead of every time. DoEvents tells Excel VBA to take a break and let WIndows process messages. Many times in a very tight loop, the macro doesn't let Windows catchup so it might look like the PC is frozen and you can't even get into task manager. 1000 just 'felt right' since I haad a counter


BTW, I chose to do it with .SpecialCells to cut out as much VBA looping as possible since a double loop (All rows and all all cols in each row) takes time, and ReDim Preserve reportedly is a slow operation so I try to avoid it as much as possible, esp. bumping up by 1 many times. I did see one example when the ReDim Preserve was used to double the allocation, and if that filled up, it was doubled again, but that was too much work


Try some other suggestions to see which is faster, AND which you feel you can maintain. IMHO 99.99% of the time there's no value to gain a few percent speed but ending with code that is overly complicated, confusing, and hard to maintain

[SamT]

Try some other suggestions to see which is faster, AND which you feel you can maintain. IMHO 99.99% of the time there's no value to gain a few percent speed but ending with code that is overly complicated, confusing, and hard to maintain

+5

[Poundland]

snb, I have added to your reputation. Thank you for your assistance.