PDA

View Full Version : [SOLVED] How to Speed up Code without Excel falling down - EXCL 2013



Poundland
08-06-2015, 05:21 AM
Guys,

I have written the code below which works fine, but it takes nearly an hour to run for just over 90k records to be filtered and collated. I have had to add a time delay into the code as without it Excel kept going into a None Responsive code and closing down.

Is there a way that I could speed up the running of the code without compromising the stability of Excel? Any suggestions would be appreciated..


Sub compile_results()
Dim Store As String, MS As String
' Switches off screen updates
Application.ScreenUpdating = False
Sheets("Skus").Select
' Code configured below to eliminate a Code 104 error, this places the focus onto the sheet.
Sheets("Skus").Cells(2, 1).Select
' Counts the number of products that have not sold in 4 weeks and assigns to a variable _
' used in For Next loop
Sheets("Results").Select
Cells(2, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Count = Selection.Count
Cells(2, 1).Select
' Start of For Next loop to compile data
For a = 1 To Count
' Takes only the first 4 characters (Store ID) and assigns to a Variable
Store = Left(ActiveCell.Value, 4)
Selection.Offset(0, 1).Select
' Takes only the first 7 characters (Master Sku) and assigns to a Variable
MS = Left(ActiveCell.Value, 7)
' Makes the Raw data sheet active
Sheets("ASR Data").Select

' Uses the Autofilters to compile individual Store Master Sku data, Filters 1 & 8
' Filter 4 ensures only products that have stock are selected
' Filter 6 selects only products that have not yet been ordered
ActiveSheet.Range("$A:$H").AutoFilter field:=1, Criteria1:=Store

ActiveSheet.Range("$A:$H").AutoFilter field:=8, Criteria1:=MS
ActiveSheet.Range("$A:$H").AutoFilter field:=4, Criteria1:=">0"
ActiveSheet.Range("$A:$H").AutoFilter field:=6, Criteria1:="0"
Sheets("ASR Data").Cells(2, 1).Select

' Selects the filtered Data
ActiveSheet.AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
' Counts the selected data to see if any data exists for the filtered selection
e = Selection.Count / 8 ' # number of headed columns
' If Then routine that copys data if it exists or resets the Filters if none exists
If e > 1 Then
ActiveSheet.AutoFilter.Range.Offset(1, 0).Copy
' Selects the Paste destination sheet
Sheets("Skus").Select
' Assigns the current Row to a variable
r = ActiveCell.Row
' Pastes the copied data
ActiveSheet.Paste
' Counts the pasted data to obtain the new Row identifier
d = Selection.Count / 8 ' # of headed columns
' Creates the new Row variable
r = r + (d - 1)
' Positions focus on the next blank cell in the Row
Sheets("Skus").Cells(r, 1).Select
' ***** THE BELOW CODE LINE WAS PUT IN TO PREVENT EXCEL FROM ENTERING A NONE RESPONSIVE MODE AND CLOSING DOWN ***
' waits for excel to cath up
Application.Wait [Now()] + TimeValue("00:00:01")

' Focus switched to Raw data sheet
Sheets("ASR Data").Select
' End of If Then statement
Else
End If
' Removes Filter criterias
ActiveSheet.ShowAllData
' Focus switched
Sheets("Results").Select
' Selects next Store / Product combination
Selection.Offset(1, -1).Select
' Next return
Next a
Sheets("Results").Select
' Switches on Screen Updating
Application.ScreenUpdating = True

End Sub

wrightyrx7
08-06-2015, 08:04 AM
Im confused...is this all the code?

I noticed alot of stuff that needs to be changed. But the loop is irrelevant in the code provided above, "a" isnt used anywhere except the FOR LOOP

Poundland
08-06-2015, 08:17 AM
Im confused...is this all the code?

I noticed alot of stuff that needs to be changed. But the loop is irrelevant in the code provided above, "a" isnt used anywhere except the FOR LOOP

The Loop is a requirement of the code as I have a variable amount of records that needs to be checked each time the code is run, the variable 'a' is assigned the number of records and thus is used to loop through them to check for filtered records each time.

And, Yes, this is all the code, it works, I used it this morning, but it took an hour to filter through 90k records, without the time delay, Excel stops responding and closes.

I am looking for a way to speed up the run time without compromising the integrity of Excel.

p45cal
08-06-2015, 08:19 AM
try:
Sub blah()
Dim Destn As Range, ResultsSheet As Worksheet, AFRng As Range, AFData As Range, cll As Range, RngToCopy As Range
Set Destn = Sheets("Skus").Range("A2")
Set ResultsSheet = Sheets("Results")
Set AFRng = Intersect(Sheets("ASR Data").UsedRange, Sheets("ASR Data").Range("$A:$H"))
Set AFData = AFRng.Resize(AFRng.Rows.Count - 1).Offset(1)
AFRng.AutoFilter Field:=4, Criteria1:=">0"
AFRng.AutoFilter Field:=6, Criteria1:="0"
For Each cll In ResultsSheet.Range(ResultsSheet.Cells(2, 1), ResultsSheet.Cells(2.1).End(xlDown)).Cells
AFRng.AutoFilter Field:=1, Criteria1:=Left(cll.Value, 4)
AFRng.AutoFilter Field:=8, Criteria1:=Left(cll.Offset(, 1).Value, 7)
Set RngToCopy = Nothing
On Error Resume Next
Set RngToCopy = AFData.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not RngToCopy Is Nothing Then
RngToCopy.Copy Destn
Set Destn = Destn.Offset(RngToCopy.Cells.Count / 8)
End If
Next cll
AFRng.AutoFilter
ResultsSheet.Select
End Sub

Poundland
08-06-2015, 08:51 AM
The Code provided works, and performs in the exact same way that my original code does but it causes Excel to go into a None Responsive mode and closes down which is why in my original code I put in the Time delay.

Any ideas, other than again putting in a time delay?

p45cal
08-06-2015, 09:00 AM
What version of Excel?
I often get the 'not responding' message in the title bar of Excel but it does continue to run a macro etc.; does yours actually shut itself down, or do you get tired of waiting.
Perhaps attach (or link to) your file? Do some Search and Replacing if there's sensitive data, or send me a PM here for an address to send it to privately.

I would hope there would be a considerable speed increase of between 50 and 100 times faster, so I'd expect it to work within 5 minutes.
Unless, that is, there is some other code working somewhere (perhaps some sheet_change events or something) that could be being triggered by our macros' manipulations.

Poundland
08-06-2015, 09:01 AM
I tried adding the time delay into the new code above, and it did nothing, Excel is still None Responsive, just running my original code again, and still working but slowly...

Poundland
08-06-2015, 09:08 AM
Thank you so far for your help.

I am using Excel 2013.

Unfortunately I cannot attach or send you my workbook as it is against my companies policy, sorry... :(

Your code certainly seems more straightforward than mine, just a shame it causes the unresponsiveness... :(

Poundland
08-06-2015, 09:09 AM
There are no sheet change events, this is the only code located on the workbook.

p45cal
08-06-2015, 09:30 AM
In the cells that are being copied, are there any formulae? Are there lots and lots of formatting?
90k cells is nothing for Excel as long as the machine it's running on is not ancient.
It shouldn't need the time delay in the code - that really would slow it down.
Without a file of sorts from you I cannot help you more
Again, does Excel crash or do you get tired of waiting?

Kenneth Hobs
08-06-2015, 11:19 AM
As p45cal showed, there is seldom a need for .Select or Selection.

Obviously, the 2.1 should be 2,1.

For Each cll In ResultsSheet.Range(ResultsSheet.Cells(2, 1), ResultsSheet.Cells(2.1).End(xlDown)).Cells
While one can use that method, I prefer a bottom up as sometimes data is missing after A2 and all of the cells except for 1 in column A would be the range set.

For Each cll In ResultsSheet.Range(ResultsSheet.Range("A2"), ResultsSheet.Range("A" & rows.count).End(xlUp))

You should turn off events and autocalculation. You can always add a worksheets("somesheetname").Calcuate where needed. See my sub, Yours(), for how to use my routine in yours.

'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
Public glb_origCalculationMode As Integer


Sub SpeedOn(Optional StatusBarMsg As String = "Running macro...")
glb_origCalculationMode = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = StatusBarMsg
.EnableCancelKey = xlErrorHandler
End With
End Sub


Sub SpeedOff()
With Application
.Calculation = glb_origCalculationMode
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.CalculateBeforeSave = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
End Sub


Sub Yours()
On Error GoTo EndSub
SpeedOn

' your stuff here

EndSub:
SpeedOff
End Sub

Sub SpeedUp()
On Error GoTo EndNow
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'code here


EndNow:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub


Sub MySub()
Dim xlInitialCalcState As XlCalculation

With Application
.ScreenUpdating = False
xlInitialCalcState = .Calculation
.Calculation = xlCalculationManual

'code here

.Calculation = xlInitialCalcState
.ScreenUpdating = True
End With
End Sub

Paul_Hossler
08-06-2015, 08:10 PM
Since you said p45cal's macro works the same, I'd suggest a couple of additional lines to see if it helps




Sub blah()
Dim Destn As Range, ResultsSheet As Worksheet, AFRng As Range, AFData As Range, cll As Range, RngToCopy As Range
Set Destn = Sheets("Skus").Range("A2")
Set ResultsSheet = Sheets("Results")
Set AFRng = Intersect(Sheets("ASR Data").UsedRange, Sheets("ASR Data").Range("$A:$H"))
Set AFData = AFRng.Resize(AFRng.Rows.Count - 1).Offset(1)
AFRng.AutoFilter Field:=4, Criteria1:=">0"
AFRng.AutoFilter Field:=6, Criteria1:="0"
For Each cll In ResultsSheet.Range(ResultsSheet.Cells(2, 1), ResultsSheet.Cells(2.1).End(xlDown)).Cells

'------------------- added
Application.Statusbar = cll.Address
DoEvents
'------------------- added


AFRng.AutoFilter Field:=1, Criteria1:=Left(cll.Value, 4)
AFRng.AutoFilter Field:=8, Criteria1:=Left(cll.Offset(, 1).Value, 7)
Set RngToCopy = Nothing

On Error Resume Next
Set RngToCopy = AFData.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not RngToCopy Is Nothing Then
RngToCopy.Copy Destn
Set Destn = Destn.Offset(RngToCopy.Cells.Count / 8)
End If
Next cll
AFRng.AutoFilter
ResultsSheet.Select
End Sub

Poundland
08-07-2015, 01:20 AM
14089
In the cells that are being copied, are there any formulae? Are there lots and lots of formatting?
90k cells is nothing for Excel as long as the machine it's running on is not ancient.
It shouldn't need the time delay in the code - that really would slow it down.
Without a file of sorts from you I cannot help you more
Again, does Excel crash or do you get tired of waiting?

Excel doesn't crash, but it does go into an unresponsive mode, and looking at Task Manager it says that it has stopped running.

I have removed sales and sensitive data and attached the excel sheet for you to tinker with, I do appreciate your help...

Due to the file upload limitations I have had to reduce the amount of data on the attachment, so you may not get a true reflection of what I am getting.

Poundland
08-07-2015, 01:24 AM
I think I have added the attachment this time round...

wrightyrx7
08-07-2015, 02:22 AM
Since you said p45cal's macro works the same, I'd suggest a couple of additional lines to see if it helps




Sub blah()
Application.Screenupdating = False
Dim Destn As Range, ResultsSheet As Worksheet, AFRng As Range, AFData As Range, cll As Range, RngToCopy As Range
Set Destn = Sheets("Skus").Range("A2")
Set ResultsSheet = Sheets("Results")
Set AFRng = Intersect(Sheets("ASR Data").UsedRange, Sheets("ASR Data").Range("$A:$H"))
Set AFData = AFRng.Resize(AFRng.Rows.Count - 1).Offset(1)
AFRng.AutoFilter Field:=4, Criteria1:=">0"
AFRng.AutoFilter Field:=6, Criteria1:="0"
For Each cll In ResultsSheet.Range(ResultsSheet.Cells(2, 1), ResultsSheet.Cells(2.1).End(xlDown)).Cells

'------------------- added
Application.Statusbar = cll.Address
DoEvents
'------------------- added


AFRng.AutoFilter Field:=1, Criteria1:=Left(cll.Value, 4)
AFRng.AutoFilter Field:=8, Criteria1:=Left(cll.Offset(, 1).Value, 7)
Set RngToCopy = Nothing

On Error Resume Next
Set RngToCopy = AFData.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not RngToCopy Is Nothing Then
RngToCopy.Copy Destn
Set Destn = Destn.Offset(RngToCopy.Cells.Count / 8)
End If
Next cll
AFRng.AutoFilter
ResultsSheet.Select
Application.Screenupdating = True
End Sub

Paul's couple of additional lines to p45cal's code will help, it will keep you updated in the bottom left corner of where it is up to.

It also stopped the crashing for me, I just disabled 'Screenupdating' to speed it up a little.

Poundland
08-07-2015, 02:31 AM
Since you said p45cal's macro works the same, I'd suggest a couple of additional lines to see if it helps




Sub blah()
Dim Destn As Range, ResultsSheet As Worksheet, AFRng As Range, AFData As Range, cll As Range, RngToCopy As Range
Set Destn = Sheets("Skus").Range("A2")
Set ResultsSheet = Sheets("Results")
Set AFRng = Intersect(Sheets("ASR Data").UsedRange, Sheets("ASR Data").Range("$A:$H"))
Set AFData = AFRng.Resize(AFRng.Rows.Count - 1).Offset(1)
AFRng.AutoFilter Field:=4, Criteria1:=">0"
AFRng.AutoFilter Field:=6, Criteria1:="0"
For Each cll In ResultsSheet.Range(ResultsSheet.Cells(2, 1), ResultsSheet.Cells(2.1).End(xlDown)).Cells

'------------------- added
Application.Statusbar = cll.Address
DoEvents
'------------------- added


AFRng.AutoFilter Field:=1, Criteria1:=Left(cll.Value, 4)
AFRng.AutoFilter Field:=8, Criteria1:=Left(cll.Offset(, 1).Value, 7)
Set RngToCopy = Nothing

On Error Resume Next
Set RngToCopy = AFData.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not RngToCopy Is Nothing Then
RngToCopy.Copy Destn
Set Destn = Destn.Offset(RngToCopy.Cells.Count / 8)
End If
Next cll
AFRng.AutoFilter
ResultsSheet.Select
End Sub

Paul,

Thank you for the code, I have just run it, it took an hour to complete for 350k records, and Excel was running throughout without any unresponsive moments. I just need to increase the Speed now, any thoughts?

P.S. I turned off screen updating as part of the code prior to running, and this had the 1 hour run time, without it, it had run for 20 minutes and had not even got a quarter of the way.

Poundland
08-07-2015, 03:15 AM
I have managed to get the run time down to 30 minutes now for 350k records by using Paul's code and the Speed options from Kenneth's code.

I think this is probably as good as it is going to get, unless anybody else has any ideas..

The code you guys have written for me is really great, I however find it very hard to learn from it as I cannot physically see what each code line does when stepping through it as most of the actions are hidden, that is why I tend to write code that I can visually see what happens so I learn from it. Don't get me wrong I appreciate your help very much.. :)

The full code I am now using is below;


Public glb_origCalculationMode As Integer


Sub SpeedOn(Optional StatusBarMsg As String = "Running macro...")
glb_origCalculationMode = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = StatusBarMsg
.EnableCancelKey = xlErrorHandler
End With
End Sub

Sub SpeedOff()
With Application
.Calculation = glb_origCalculationMode
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.CalculateBeforeSave = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
End Sub

Sub blah2()
On Error GoTo EndSub
SpeedOn
Dim Destn As Range, ResultsSheet As Worksheet, AFRng As Range, AFData As Range, cll As Range, RngToCopy As Range
Set Destn = Sheets("Skus").Range("A2")
Set ResultsSheet = Sheets("Results")
Set AFRng = Intersect(Sheets("ASR Data").UsedRange, Sheets("ASR Data").Range("$A:$H"))
Set AFData = AFRng.Resize(AFRng.Rows.Count - 1).Offset(1)
AFRng.AutoFilter Field:=4, Criteria1:=">0"
AFRng.AutoFilter Field:=6, Criteria1:="0"
For Each cll In ResultsSheet.Range(ResultsSheet.Cells(2, 1), ResultsSheet.Cells(2, 1).End(xlDown)).Cells

'------------------- added
Application.StatusBar = cll.Address
DoEvents
'------------------- added


AFRng.AutoFilter Field:=1, Criteria1:=Left(cll.Value, 4)
AFRng.AutoFilter Field:=8, Criteria1:=Left(cll.Offset(, 1).Value, 7)
Set RngToCopy = Nothing

On Error Resume Next
Set RngToCopy = AFData.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not RngToCopy Is Nothing Then
RngToCopy.Copy Destn
Set Destn = Destn.Offset(RngToCopy.Cells.Count / 8)
End If
Next cll
AFRng.AutoFilter
ResultsSheet.Select
Application.ScreenUpdating = True
EndSub:
SpeedOff
End Sub

wrightyrx7
08-07-2015, 03:22 AM
IGNORE THIS POST my theory wont work haha
Sorry

wrightyrx7
08-07-2015, 04:45 AM
Ok i got the same results using a different Tactic haha

On the 'Results' sheet (column D). I created a kind of serial number, which is the StoreID and Style Code (together) using this formula:


=LEFT(A2,4)&LEFT(B2,7)




Then my code does the rest.



Sub blah()
Dim AFRng As Range, AFData As Range
Dim lRow As Long


Application.ScreenUpdating = False

Set AFRng = Intersect(Sheets("ASR Data").UsedRange, Sheets("ASR Data").Range("$A:$H"))
Set AFData = AFRng.Resize(AFRng.Rows.Count - 1).Offset(1)
AFRng.AutoFilter Field:=4, Criteria1:=">0"
AFRng.AutoFilter Field:=6, Criteria1:="0"
AFData.SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("Skus").Range("A2")

With Worksheets("Skus")
lRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("I2:I" & lRow).Formula = "=A2&H2"
.Range("J2:J" & lRow).Formula = "=VLOOKUP(I2,Results!D:D,1,0)"
.Range("J2:J" & lRow).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
.Range("I2:J" & lRow).ClearContents
End With

AFRng.AutoFilter
Worksheets("Results").Select
Application.ScreenUpdating = True
End Sub

Poundland
08-07-2015, 05:21 AM
Hi Wright,

I tried your code, it did indeed work faster although long delay in the row delete process but due to the formulas being in the deletion. Major issue though is that it missed some of the data that met the criteria, so it is flawed in that respect. I liked the idea though.. ;)

wrightyrx7
08-07-2015, 05:58 AM
Dammit, heres me thinking i cracked it haha.

Changing the formula's to values before deletion wouldnt of been a problem.

Poundland
08-07-2015, 06:04 AM
Dammit, heres me thinking i cracked it haha.

Changing the formula's to values before deletion wouldnt of been a problem.

It was a good effort and we would have got away with it if it hadn't have been for those pesky kids... ala Scooby Doo.. :D

wrightyrx7
08-07-2015, 06:15 AM
It was a good effort and we would have got away with it if it hadn't have been for those pesky kids... ala Scooby Doo.. :D

Haha i know yeah! Im stumped as to why my code didnt work, i cant figure it out :(

Will be nice to see what one of the more experienced people in these forums come up with

Paul_Hossler
08-07-2015, 07:04 AM
In WORDS what are you trying to do, and is there a small WB available?

wrightyrx7
08-07-2015, 07:11 AM
Paul he has a smaller version of his workbook on the previous page.

In theory there are 4 filters applied at any one time.

Two are static (current code)


AFRng.AutoFilter Field:=4, Criteria1:=">0"
AFRng.AutoFilter Field:=6, Criteria1:="0"


and the other two filters are determined by a loop which is going through the rows on another worksheet. (current code)


For Each cll In ResultsSheet.Range(ResultsSheet.Cells(2, 1), ResultsSheet.Cells(2.1).End(xlDown)).Cells
AFRng.AutoFilter Field:=1, Criteria1:=Left(cll.Value, 4)
AFRng.AutoFilter Field:=8, Criteria1:=Left(cll.Offset(, 1).Value, 7)



Each time the filters are applied and contains data, the data is copied to a third sheet. Thats basically it, unless Poundland has something to add....

Hope that makes sense because it does in my head haha

Poundland
08-07-2015, 07:19 AM
Paul he has a smaller version of his workbook on the previous page.

In theory there are 4 filters applied at any one time.

Two are static (current code)


AFRng.AutoFilter Field:=4, Criteria1:=">0"
AFRng.AutoFilter Field:=6, Criteria1:="0"


and the other two filters are determined by a loop which is going through the rows on another worksheet. 9current code)


For Each cll In ResultsSheet.Range(ResultsSheet.Cells(2, 1), ResultsSheet.Cells(2.1).End(xlDown)).Cells
AFRng.AutoFilter Field:=1, Criteria1:=Left(cll.Value, 4)
AFRng.AutoFilter Field:=8, Criteria1:=Left(cll.Offset(, 1).Value, 7)



Each time the filters are applied and contains data, the data is copied to a third sheet. Thats basically it, unless Poundland has something to add....

Hope that makes sense because it does in my head haha

Perfectly explained....

The purpose is, that I have over 600 stores and a range of product ranges to manage, I have determined which product ranges by which stores have not generated any sales in the last 4 weeks.

The ASR Data Sheet contains the full list of products in the ranges including individual store stocks, the Results sheet determined by another Macro code are the store and product type combinations that have not generated sales, using one with the other, I am compiling a list of products specific to each store of the type so that the store can check to make sure that they have merchandised them correctly and that they actually have stock of them.

I will then be using the results on the Sku sheets to email to each store the products they need to check...

Hope that helps, and thanks for the help...

Kenneth Hobs
08-07-2015, 08:42 AM
I am with Paul.

While I like to see code that you have tried, it may not be an approach that accomplishes all of your goals. Your last goal appears to be decrease execution time.

If I understood the part after filtering by On Hand>0 and SOQ Actual=0, I would probably use an array or maybe a custom filter. For the custom filter approach, you can try doing that manually. What you might want to do is to copy a sheet, and then Filter-in-Place.

p45cal
08-10-2015, 04:35 AM
try:
Sub blah2()
On Error GoTo Errhandler
Sheets("Skus").UsedRange.Offset(1).EntireRow.Delete
'StartTime = Timer
Application.ScreenUpdating = False
Dim SkusArray()
ReDim SkusArray(1 To 8, 1 To 1)

Sheets("Results").Copy before:=Sheets(1) 'I only copy sheets to preserve sort order on original sheets.
With ActiveSheet
Set myrng = Intersect(.UsedRange, .Range("A:B"))
myrng.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
resultsarray = myrng.Value
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Sheets("ASR Data").Copy before:=Sheets(1)
With ActiveSheet
Set myrng = Intersect(.UsedRange, .Range("A:H"))
myrng.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range("H2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
ASRArray = myrng.Value
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
SkusCount = 0
j2 = 2
For i = 2 To UBound(resultsarray)
ThisShop = Left(resultsarray(i, 1), 4)
FirstThisShopFound = False
For j = j2 To UBound(ASRArray)
If ThisShop = CStr(ASRArray(j, 1)) Then
If Not FirstThisShopFound Then j2 = j
FirstThisShopFound = True
If Left(resultsarray(i, 2), 7) = ASRArray(j, 8) Then
If ASRArray(j, 4) > 0 Then
If ASRArray(j, 6) = 0 Then
SkusCount = SkusCount + 1
ReDim Preserve SkusArray(1 To 8, 1 To SkusCount)
For k = 1 To 8
SkusArray(k, SkusCount) = ASRArray(j, k)
Next k
End If
End If
End If
Else
If FirstThisShopFound Then
If Left(resultsarray(Application.Min(UBound(resultsarray), i + 1), 1), 4) <> ThisShop Then
'Stop
j2 = j
End If
Exit For
End If
End If
Next j
Next i
Sheets("Skus").Range("A2").Resize(UBound(SkusArray, 2), 8) = Application.Transpose(SkusArray)
Sheets("Skus").Select
'MsgBox Timer - StartTime
Errhandler:
Application.ScreenUpdating = True
End Sub
The aims here were (1) to do most of the processing in-memory and (2) to reduce looping as much as possible by sorting both sets of data first. Developed on an Excel 2003 machine so the sorting code is not the latest.
Took 2 seconds on a steam-powered machine; I'd be interested to know how fast it is on a full data set.

It's not streamlined (I worked on it until it gave the same results as before, then stopped!).
Be aware, an early line in the code deletes everything on Sheet Skus from row 2 down - so hopefuly you have nothing elsewhere on that sheet you want to keep.

Poundland
08-18-2015, 03:32 AM
P45Cal,

Your Code worked, and worked incredibly quickly, unfortunately it missed a whole load of products that it should have picked up.

Without knowing what each code line does, I cannot pinpoint where the issue lies.

Thank you for your help however. Much appreciated.

p45cal
08-18-2015, 07:09 AM
unfortunately it missed a whole load of products that it should have picked up.
Without knowing what each code line does, I cannot pinpoint where the issue lies.
Did it give the correct results on the sample file you provided? (When I tested it versus your code on that file, it gave the same results.)
Without knowing what products it should have picked up but didn't, I cannot pinpoint where the problem lies.

SamT
08-19-2015, 06:15 AM
Poundland,

I am trying to analyze what you are trying to accomplish. Your code tells me exactly how you are trying to do it, but not what you are trying to achieve. There may be a much faster method to accomplish what you need done.

My best guess is that you receive on a daily basis, the data in Sheets("ASR Data" in some form or another, and that you must extract only the data for certain stock items, but only from certain stores.

IOW, some non-listed stores may use some of the listed Items, but you are not interested in that data and some listed items may be in stores you are interested in, but, again, you are not interested in that data since your list does not have that Item next to that Store.

For example, you are only interested in Item BT00016 (AAA RECHARGEABLE 2PK) when it is in Store 1411 (P411 Oxford), even though Style BT00016, (in many different SKU IDs,) is reported in over 600 stores, many of which are in the list in Sheets Results.
'

Looking at your Example, "Macro Data," Sheet, "Results, "I see that you are interested in 264 unique Item Styles located in 597 stores.

The ASR Data Sheet contains 50 unique Item Styles and 62 store IDs. Presumably, the actual data set contains more items and stores than this.

In the Macro Data Workbook, you have the Store and Master Sku's listed in the Results Worksheet and the Filter Results in the Skus worksheet. Did you misname these sheets?

'

In what format do you receive the daily ASR Data? What is the name of the file, or what pattern does the Name follow?

How often does your reference list, currently on sheets Results, change?

Poundland
08-27-2015, 08:04 AM
I have tested P45Cal's code again with another subset of data and it pulled over the desired results, it seems you cracked it the first time, there was just so much data that I couldn't see the wood for the trees...lol

Thank you so much to everybody who helped me on this...

I have learned a lot, and have written some new code for another project that I am a little stuck on so will create a separate thread for this...

snb
08-27-2015, 10:45 AM
I fear a pivottable combined with a slicer would do the job.

p45cal
08-27-2015, 01:29 PM
I have tested P45Cal's code again with another subset of data and it pulled over the desired results
I'd be interested to know how fast it is on a full data set.


I fear a pivottable combined with a slicer would do the job.I'd be interested in seeing that on the OP's file. Any chance?

Poundland
08-28-2015, 07:23 AM
I'd be interested to know how fast it is on a full data set.


It took about 5 minutes to run on a full data set, so much faster than any other solution I was offered.. Thanks again buddy