Code run a little slow

H

Hyakkivn

Board Regular
Joined
Jul 28, 2021
Messages
81
Office Version
  1. 2010
Platform
  1. Windows
Hello brothers and sisters. Below is my code for copy paste from 3rd party software and calculate the weight of product. But it runs a little slow. It takes 7 sec for running just a few lines of code.
Are there methods for make it faster? Thanks in advanced!
VBA Code: 
Sub Sumweight()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim wb As Workbook
Dim erow As Long
Dim a As Range
Set wb = ActiveWorkbook
Set s1 = wb.Sheets("Sheet1")
Set s2 = wb.Sheets("Sheet2")
Set s3 = wb.Sheets("Sheet3")
s1.Range("A1:W200").ClearContents
s2.Range("A1:E20").ClearContents
'Work with Sheet1
Set a = s1.Cells(1, 1)
s1.Activate
a.Activate
s1.PasteSpecial Format:="Unicode Text"
'Work with Sheet2
s2.Activate
s2.Range("A:A").Value = s1.Range("Q:Q").Value
s2.Range("B:B").Value = s1.Range("J:J").Value
s2.Range("C:C").Value = s1.Range("S:S").Value
s2.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
For Each cel In s2.Range("B2:B20")
If InStr(1, "k", cel.Value) Or InStr(1, "", cel.Value) Then
cel.EntireRow.Delete
End If
Next
For Each cel1 In s2.Range("A2:A20")
If InStr(1, "Ô tô", cel1.Value) Then
cel1.EntireRow.Delete
End If
Next
Lr1 = s1.Range("A" & Rows.Count).End(xlUp).Row
Lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
Set hdt = s2.Range("D2:D" & Range("A" & Rows.Count).End(xlUp).Row)
s2.Range("D2:D" & Lr2).Formula = "=SUMIFS(Sheet1!$I$2:$I$" & Lr1 & ",Sheet1!$Q$2:$Q$" & Lr1 & ",A2,Sheet1!$J$2:$J$" & Lr1 & ",B2,Sheet1!$S$2:$S$" & Lr1 & ",C2)"
For Each c In hdt
c.Value = c.Value
Next
'Creat droplist in Sheet3
s2.Range("E:E").Value = s2.Range("A:A").Value
s2.Range("E:E").RemoveDuplicates Columns:=1, Header:=xlYes
erow = s2.Range("E2").End(xlDown).Row
Set rngList = s2.Range("E2", "E" & erow)
wb.Names.Add Name:="List1", RefersTo:=rngList
s3.Range("B2").Validation.Delete
s3.Range("B2").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=List1"
s3.Activate

End Sub
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Sort by date Sort by votes
Hi,

set calculation to manual at the start and automatic at the end?

Holger
 
Upvote 0
VBA Code: 
hdt.Value = hdt.Value
rather than
VBA Code: 
For Each c In hdt
c.Value = c.Value
Next

and avoid the use of Activate. Reference the cells, ranges and sheets directly. The only Activate should be the last one in the code (if you aren't starting on s3)
 
Upvote 0
HaHoBe said:
Hi,

set calculation to manual at the start and automatic at the end?

Holger
Click to expand...
I try that method. The code still run slows. Maybe I use array in code.
Each time I run the code, file size increase gradually or greatly. From 32kb to 5mb
Any suggestion please?
 
Upvote 0
MARK858 said:
VBA Code: 
hdt.Value = hdt.Value
rather than
VBA Code: 
For Each c In hdt
c.Value = c.Value
Next

and avoid the use of Activate. Reference the cells, ranges and sheets directly. The only Activate should be the last one in the code (if you aren't starting on s3)
Click to expand...
Thank you. I will remove the For Next
 
Upvote 0
Hi Hyakkivn,

please try this code (untested):

VBA Code: 
Sub Sumweight()
' https://www.mrexcel.com/board/threads/code-run-a-little-slow.1224346/
' Reason:  Straightened code
' By:      HaHoBe

Dim wb As Workbook
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet

Dim rngCell As Range
Dim rngDel As Range
Dim rngList As Range

Dim lngLR1 As Long
Dim lngLR2 As Long

On Error GoTo end_here

Set wb = ActiveWorkbook
Set s1 = wb.Sheets("Sheet1")
Set s2 = wb.Sheets("Sheet2")
Set s3 = wb.Sheets("Sheet3")
With Application
  .DisplayAlerts = False
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
  .EnableEvents = False
End With

s1.Range("A1:W200").ClearContents
s2.Range("A1:E20").ClearContents

'Work with Sheet1
s1.Cells(1, 1).PasteSpecial Format:="Unicode Text"

'Work with Sheet2
s2.Range("A:A").Value = s1.Range("Q:Q").Value
s2.Range("B:B").Value = s1.Range("J:J").Value
s2.Range("C:C").Value = s1.Range("S:S").Value
s2.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
For Each rngCell In s2.Range("B2:B20")
  If InStr(1, "k", rngCell.Value) Or InStr(1, "", rngCell.Value) Then
    If rngDel Is Nothing Then
      Set rngDel = rngCell
    Else
      Set rngDel = Union(rngDel, rngCell)
    End If
  End If
Next
For Each rngCell In s2.Range("A2:A20")
  If InStr(1, "Ô tô", rngCell.Value) Then
    If rngDel Is Nothing Then
      Set rngDel = rngCell
    Else
      Set rngDel = Union(rngDel, rngCell)
    End If
  End If
Next
If Not rngDel Is Nothing Then
  rngDel.EntireRow.Delete
  Set rngDel = Nothing
End If

lngLR1 = s1.Range("A" & Rows.Count).End(xlUp).Row
lngLR2 = s2.Range("A" & Rows.Count).End(xlUp).Row
With s2.Range("D2:D" & lngLR2)
  .Formula = "=SUMIFS(Sheet1!$I$2:$I$" & lngLR1 & ",Sheet1!$Q$2:$Q$" & lngLR1 & ",A2,Sheet1!$J$2:$J$" & lngLR1 & ",B2,Sheet1!$S$2:$S$" & lngLR1 & ",C2)"
  .Value = .Value
End With
'Create droplist in Sheet3
With s2.Range("E:E")
  .Value = s2.Range("A:A").Value
  .RemoveDuplicates Columns:=1, Header:=xlYes   'you already removed duplicates form Column A before, yet do it again?
End With
Set rngList = s2.Range("E2", s2.Range("E2").End(xlDown))
wb.Names.Add Name:="List1", RefersTo:=rngList
With s3.Range("B2")
  .Validation.Delete
  .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=List1"
End With
s3.Activate

end_here:
If Err <> 0 Then
  MsgBox "Error number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description, vbExclamation, "Error occurred"
End If
Set rngList = Nothing
Set s3 = Nothing
Set s2 = Nothing
Set s1 = Nothing
Set wb = Nothing
With Application
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .ScreenUpdating = True
End With

End Sub

About the growing file size: what fileformat do you use? Any code as events in ThisWorkbook or behind the sheets? Have you checked the worksheets for the UsedRange and eventually deleted all rows and columns exceeding the areas?

Holger
 
Upvote 0
Solution
HaHoBe said:
Hi Hyakkivn,

please try this code (untested):

VBA Code: 
Sub Sumweight()
' https://www.mrexcel.com/board/threads/code-run-a-little-slow.1224346/
' Reason:  Straightened code
' By:      HaHoBe

Dim wb As Workbook
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet

Dim rngCell As Range
Dim rngDel As Range
Dim rngList As Range

Dim lngLR1 As Long
Dim lngLR2 As Long

On Error GoTo end_here

Set wb = ActiveWorkbook
Set s1 = wb.Sheets("Sheet1")
Set s2 = wb.Sheets("Sheet2")
Set s3 = wb.Sheets("Sheet3")
With Application
  .DisplayAlerts = False
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
  .EnableEvents = False
End With

s1.Range("A1:W200").ClearContents
s2.Range("A1:E20").ClearContents

'Work with Sheet1
s1.Cells(1, 1).PasteSpecial Format:="Unicode Text"

'Work with Sheet2
s2.Range("A:A").Value = s1.Range("Q:Q").Value
s2.Range("B:B").Value = s1.Range("J:J").Value
s2.Range("C:C").Value = s1.Range("S:S").Value
s2.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
For Each rngCell In s2.Range("B2:B20")
  If InStr(1, "k", rngCell.Value) Or InStr(1, "", rngCell.Value) Then
    If rngDel Is Nothing Then
      Set rngDel = rngCell
    Else
      Set rngDel = Union(rngDel, rngCell)
    End If
  End If
Next
For Each rngCell In s2.Range("A2:A20")
  If InStr(1, "Ô tô", rngCell.Value) Then
    If rngDel Is Nothing Then
      Set rngDel = rngCell
    Else
      Set rngDel = Union(rngDel, rngCell)
    End If
  End If
Next
If Not rngDel Is Nothing Then
  rngDel.EntireRow.Delete
  Set rngDel = Nothing
End If

lngLR1 = s1.Range("A" & Rows.Count).End(xlUp).Row
lngLR2 = s2.Range("A" & Rows.Count).End(xlUp).Row
With s2.Range("D2:D" & lngLR2)
  .Formula = "=SUMIFS(Sheet1!$I$2:$I$" & lngLR1 & ",Sheet1!$Q$2:$Q$" & lngLR1 & ",A2,Sheet1!$J$2:$J$" & lngLR1 & ",B2,Sheet1!$S$2:$S$" & lngLR1 & ",C2)"
  .Value = .Value
End With
'Create droplist in Sheet3
With s2.Range("E:E")
  .Value = s2.Range("A:A").Value
  .RemoveDuplicates Columns:=1, Header:=xlYes   'you already removed duplicates form Column A before, yet do it again?
End With
Set rngList = s2.Range("E2", s2.Range("E2").End(xlDown))
wb.Names.Add Name:="List1", RefersTo:=rngList
With s3.Range("B2")
  .Validation.Delete
  .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=List1"
End With
s3.Activate

end_here:
If Err <> 0 Then
  MsgBox "Error number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description, vbExclamation, "Error occurred"
End If
Set rngList = Nothing
Set s3 = Nothing
Set s2 = Nothing
Set s1 = Nothing
Set wb = Nothing
With Application
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .ScreenUpdating = True
End With

End Sub

About the growing file size: what fileformat do you use? Any code as events in ThisWorkbook or behind the sheets? Have you checked the worksheets for the UsedRange and eventually deleted all rows and columns exceeding the areas?

Holger
Click to expand...
Error number 1004
Application-defined or object-defined error ^_^!
'you already removed duplicates form Column A before, yet do it again?
Click to expand...
Yes, there are 2 time remove duplicates. (For 2 different purposes)
 
Upvote 0
What line are you getting the error on?
 
Upvote 0
Hi Hyakkivn,

codeline in question should be

VBA Code: 
'Work with Sheet1
s1.Cells(1, 1).PasteSpecial Format:="Unicode Text"

Try changing the code to

VBA Code: 
'Work with Sheet1
With Application
  .Goto s1.Cells(1, 1)
  If .ClipboardFormats(1) <> -1 Then
    If .CutCopyMode Then
      s1.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
    Else
      s1.PasteSpecial Format:="Text"
    End If
  End If
  .CutCopyMode = False
End With

Holger
 
Upvote 0
Thanks everyone.
With all of your suggestion, finally, I made the code run properly.
You guys are such a big help. Once again, thank you from bottom of my heart !
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question
Find last row of sheet based off cell value to reference the sheet name
Replies
0
Views
232
ItalianPlatinum
I
H
  • Question
Combine text in cells with font color retained
2 3
Replies
26
Views
2K
Zot
Z
A
  • Question
Remove Duplicates and Copy Data in Column F
Replies
1
Views
316
Legacy 143009
L
M
  • Question
Removing self from CC in email generated from Excel.
Replies
0
Views
323
Mr Rice
M
H
  • Question
How to copy only required numbers of rows from filtered column as per criteria to another sheet -Audit sample
Replies
1
Views
453
hellodj143
H

Forum statistics

Threads
1,215,831
Messages
6,127,145
Members
449,363
Latest member
Yap999

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top