Poundland
10-18-2016, 02:06 AM
Guys,
I again call upon your collective wisdom, below is some code I have written and the workbook is attached. The code basically capture objects, compares the objects and then records objects onto a separate worksheet if they meet a given criteria.
The code works and well but it runs slow, it can take up to 30 minutes to run through, and I am looking to improve the speed.
Can you help me... Any help will be greatly appreciated. :yes
Sub Update_Matrix()
Dim rngStore As Range, rngProduct As Range, rngSales As Range, rngStock As Range
Dim shtSales As Worksheet, shtStock As Worksheet, shtMatrix As Worksheet
Dim rngMSDestn As Range, rngMPDestn As Range, rngMSaDestn As Range, rngMStDestn As Range
Dim rngStoreNum As Range, rngStockRw As Range, rngStockCol As Range
Dim shtRange As Worksheet, rngRange As Range, rngVerify As Range
Application.Calculation = xlCalculationManual
With ThisWorkbook
Set shtSales = Sheets("Christmas Sales")
Set shtStock = Sheets("Christmas Stock")
Set shtMatrix = Sheets("Store Matrix")
Set shtRange = Sheets("Range")
End With
Set rngRange = shtRange.Columns(3)
shtMatrix.Range("A2:D500000").ClearContents
Set rngMSDestn = shtMatrix.Cells(2, 1)
Set rngMPDestn = shtMatrix.Cells(2, 2)
Set rngMStDestn = shtMatrix.Cells(2, 3)
Set rngMSaDestn = shtMatrix.Cells(2, 4)
CountProduct = 0
shtStock.Select
For Each rngVerify In shtRange.Range(Cells(2, 3), Cells(2, 3).End(xlDown))
'For Each rngProduct In shtStock.Range(Cells(9, 3), Cells(9, 3).End(xlToRight))
With shtStock.Rows(9)
Set rngProduct = .Find(rngVerify, , , xlWhole)
End With
If Not rngProduct Is Nothing Then
'With rngRange
' Set rngVerify = .Find(rngProduct, , , xlWhole)
'End With
'If Not rngVerify Is Nothing Then
CountProduct = CountProduct + 1
CountStore = 0
shtStock.Select ' added for rngverify speed check
For Each rngStore In shtStock.Range(Cells(11, 2), Cells(11, 2).End(xlDown))
Set rngStoreNum = rngStore.Offset(0, -1)
Set rngStock = shtStock.Cells(rngStore.Row, rngProduct.Column)
With shtSales.Columns(1)
Set rngstockrow = .Find(rngStoreNum, LookIn:=xlValues)
End With
With shtSales.Rows(9)
Set rngStockCol = .Find(rngProduct)
End With
On Error Resume Next
Set rngSales = shtSales.Cells(rngstockrow.Row, rngStockCol.Column)
On Error GoTo 0
'Debug.Print ("Store " & rngStore & " Product " & rngProduct & " Sales " & rngSales & " Stock " & rngStock)
'If Not rngSales Is Nothing Then GoTo SalesnStock Else
On Error Resume Next
If rngSales.Value = "" Then
Set rngSales = shtSales.Cells(1, 1)
On Error GoTo 0
'If Not rngStock Is Nothing Then
If rngStock.Value <> "" Then
rngMSDestn.Value = rngStore.Value
rngMPDestn.Value = rngProduct.Value
rngMStDestn.Value = rngStock.Value
rngMSaDestn.Value = rngSales.Value
Set rngMSDestn = rngMSDestn.Offset(1, 0)
Set rngMPDestn = rngMPDestn.Offset(1, 0)
Set rngMStDestn = rngMStDestn.Offset(1, 0)
Set rngMSaDestn = rngMSaDestn.Offset(1, 0)
Else
If rngStock.Value = "" Or rngStock.Value < 0 Then
Set rngStock = shtSales.Cells(1, 1)
rngMSDestn.Value = rngStore.Value
rngMPDestn.Value = rngProduct.Value
rngMStDestn.Value = rngStock.Value
rngMSaDestn.Value = rngSales.Value
Set rngMSDestn = rngMSDestn.Offset(1, 0)
Set rngMPDestn = rngMPDestn.Offset(1, 0)
Set rngMStDestn = rngMStDestn.Offset(1, 0)
Set rngMSaDestn = rngMSaDestn.Offset(1, 0)
Else
End If
End If
End If
SalesnStock:
CountStore = CountStore + 1
Set rngSales = Nothing
Set rngStock = Nothing
Next rngStore
Else
End If
Next rngVerify
'Next rngProduct
Application.Calculation = xlCalculationAutomatic
Debug.Print ("No of Products = " & CountProduct)
Debug.Print ("No of Stores = " & CountStore)
End Sub
I again call upon your collective wisdom, below is some code I have written and the workbook is attached. The code basically capture objects, compares the objects and then records objects onto a separate worksheet if they meet a given criteria.
The code works and well but it runs slow, it can take up to 30 minutes to run through, and I am looking to improve the speed.
Can you help me... Any help will be greatly appreciated. :yes
Sub Update_Matrix()
Dim rngStore As Range, rngProduct As Range, rngSales As Range, rngStock As Range
Dim shtSales As Worksheet, shtStock As Worksheet, shtMatrix As Worksheet
Dim rngMSDestn As Range, rngMPDestn As Range, rngMSaDestn As Range, rngMStDestn As Range
Dim rngStoreNum As Range, rngStockRw As Range, rngStockCol As Range
Dim shtRange As Worksheet, rngRange As Range, rngVerify As Range
Application.Calculation = xlCalculationManual
With ThisWorkbook
Set shtSales = Sheets("Christmas Sales")
Set shtStock = Sheets("Christmas Stock")
Set shtMatrix = Sheets("Store Matrix")
Set shtRange = Sheets("Range")
End With
Set rngRange = shtRange.Columns(3)
shtMatrix.Range("A2:D500000").ClearContents
Set rngMSDestn = shtMatrix.Cells(2, 1)
Set rngMPDestn = shtMatrix.Cells(2, 2)
Set rngMStDestn = shtMatrix.Cells(2, 3)
Set rngMSaDestn = shtMatrix.Cells(2, 4)
CountProduct = 0
shtStock.Select
For Each rngVerify In shtRange.Range(Cells(2, 3), Cells(2, 3).End(xlDown))
'For Each rngProduct In shtStock.Range(Cells(9, 3), Cells(9, 3).End(xlToRight))
With shtStock.Rows(9)
Set rngProduct = .Find(rngVerify, , , xlWhole)
End With
If Not rngProduct Is Nothing Then
'With rngRange
' Set rngVerify = .Find(rngProduct, , , xlWhole)
'End With
'If Not rngVerify Is Nothing Then
CountProduct = CountProduct + 1
CountStore = 0
shtStock.Select ' added for rngverify speed check
For Each rngStore In shtStock.Range(Cells(11, 2), Cells(11, 2).End(xlDown))
Set rngStoreNum = rngStore.Offset(0, -1)
Set rngStock = shtStock.Cells(rngStore.Row, rngProduct.Column)
With shtSales.Columns(1)
Set rngstockrow = .Find(rngStoreNum, LookIn:=xlValues)
End With
With shtSales.Rows(9)
Set rngStockCol = .Find(rngProduct)
End With
On Error Resume Next
Set rngSales = shtSales.Cells(rngstockrow.Row, rngStockCol.Column)
On Error GoTo 0
'Debug.Print ("Store " & rngStore & " Product " & rngProduct & " Sales " & rngSales & " Stock " & rngStock)
'If Not rngSales Is Nothing Then GoTo SalesnStock Else
On Error Resume Next
If rngSales.Value = "" Then
Set rngSales = shtSales.Cells(1, 1)
On Error GoTo 0
'If Not rngStock Is Nothing Then
If rngStock.Value <> "" Then
rngMSDestn.Value = rngStore.Value
rngMPDestn.Value = rngProduct.Value
rngMStDestn.Value = rngStock.Value
rngMSaDestn.Value = rngSales.Value
Set rngMSDestn = rngMSDestn.Offset(1, 0)
Set rngMPDestn = rngMPDestn.Offset(1, 0)
Set rngMStDestn = rngMStDestn.Offset(1, 0)
Set rngMSaDestn = rngMSaDestn.Offset(1, 0)
Else
If rngStock.Value = "" Or rngStock.Value < 0 Then
Set rngStock = shtSales.Cells(1, 1)
rngMSDestn.Value = rngStore.Value
rngMPDestn.Value = rngProduct.Value
rngMStDestn.Value = rngStock.Value
rngMSaDestn.Value = rngSales.Value
Set rngMSDestn = rngMSDestn.Offset(1, 0)
Set rngMPDestn = rngMPDestn.Offset(1, 0)
Set rngMStDestn = rngMStDestn.Offset(1, 0)
Set rngMSaDestn = rngMSaDestn.Offset(1, 0)
Else
End If
End If
End If
SalesnStock:
CountStore = CountStore + 1
Set rngSales = Nothing
Set rngStock = Nothing
Next rngStore
Else
End If
Next rngVerify
'Next rngProduct
Application.Calculation = xlCalculationAutomatic
Debug.Print ("No of Products = " & CountProduct)
Debug.Print ("No of Stores = " & CountStore)
End Sub