PDA

View Full Version : [SOLVED] Help Required to make code run faster



Poundland
01-05-2016, 09:51 AM
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
01-05-2016, 10:43 AM
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
01-05-2016, 12:00 PM
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
01-05-2016, 01:55 PM
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
01-06-2016, 02:11 AM
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
01-06-2016, 02:16 AM
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
01-06-2016, 02:47 AM
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
01-06-2016, 03:06 AM
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
01-06-2016, 03:16 AM
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
01-06-2016, 03:57 AM
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
01-06-2016, 04:55 AM
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
01-06-2016, 06:50 AM
from > 2 hours to < 10 seconds....

Paul_Hossler
01-06-2016, 07:03 AM
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
01-06-2016, 10:53 AM
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
01-07-2016, 03:34 AM
snb, I have added to your reputation. Thank you for your assistance.