PDA

View Full Version : performance issue



sandero
07-27-2006, 06:13 AM
Hi,

i'm a student, i do a job in a company during this vacation.
I was asked today to write a VBA code in excel that combines data from 3 worksheets, but it has to loop through all records every time he needs something, how to make this code more performant (for 2000 records, it takes 50 minutes!!)

the story is : there are 3 worksheets: products, product-component and animal-microorganisms.
for products, we need to request import licenses for international shipping,
so we need a few attributes of products: product number, where it has been produced (usually USA), and quantity, then the components are searched of that product, in the product - component worksheet. then the ingredients (animals or micro organisms) are added for both products and components

greetz, sander

btw sorry for my bad english

the example file is running the program, and probably will do so for the next hour, and the problem is, my hours are from 8.30 am to 5 pm and 5 pm is in 12 minutes over here :)

tomorrow ill be able to add example file, but it would be great if you look at it allready, cause my job period (wich was a month) ends tomorrow at noon

Sub test()

'define number of records in products
Dim C As Integer
Dim counter As Integer
Dim counter1 As Integer
Dim counter2 As Integer
Dim counter3 As Integer
Dim Value1 As String
Dim Value2 As String

C = Telrecords("Products")

'copy of required product attributes to the other worksheet
Sheet1.Activate
Range(Cells(1, 2), Cells(C, 2)).Copy
Sheet8.Select
Range("A1").PasteSpecial

Sheet1.Activate
Range(Cells(1, 6), Cells(C, 6)).Copy
Sheet8.Select
Range("B1").PasteSpecial

Sheet1.Activate
Range(Cells(1, 9), Cells(C, 11)).Copy
Sheet8.Select
Range("C1").PasteSpecial

Sheet1.Activate
Range(Cells(1, 19), Cells(C, 19)).Copy
Sheet8.Select
Range("F1").PasteSpecial
'end of copy

'testing insert rows
'For counter = 4 To (Telrecords("Sheet1")) * 2 Step 2
'Range(Cells(counter - 1, 1), Cells(counter - 1, 1)).Select
'ActiveCell.EntireRow.Insert shift:=xlUp
'Next


'For counter = 2 To (Telrecords("Products") + Telrecords("Product-Component") + Telrecords("Animal-MicroOrganisms"))
For counter = 20 To 25
'For counter = 2 To C
Value1 = Worksheets("Sheet1").Cells(counter, 1).Value


'insertion of the components and their animal-microorganism values
For counter1 = 1 To Telrecords("Product-Component")
Sheet2.Activate
If ActiveSheet.Cells(counter1, 1).Value = Value1 Then
Sheet8.Activate
Range(Cells(counter + 1, 1), Cells(counter + 1, 1)).Select
ActiveCell.EntireRow.Insert shift:=xlDown
C = C + 1
Sheet2.Activate
Range(Cells(counter1, 2), Cells(counter1, 2)).Copy
Sheet8.Activate
Range(Cells(counter + 1, 7), Cells(counter + 1, 7)).PasteSpecial
Sheet2.Activate
counter = counter + 1
Value2 = Worksheets("Product-Component").Cells(counter1, 2).Value

For counter3 = 1 To Telrecords("Animal-MicroOrganisms")
Sheet3.Activate
If ActiveSheet.Cells(counter3, 1).Value = Value2 Then
Sheet8.Activate
Range(Cells(counter + 1, 1), Cells(counter + 1, 1)).Select
ActiveCell.EntireRow.Insert shift:=xlDown
C = C + 1
Sheet3.Activate
Range(Cells(counter3, 3), Cells(counter3, 5)).Copy
Sheet8.Activate
Range(Cells(counter + 1, 8), Cells(counter + 1, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheet3.Activate
Range(Cells(counter3, 8), Cells(counter3, 9)).Copy
Sheet8.Activate
Range(Cells(counter + 1, 11), Cells(counter + 1, 11)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
counter = counter + 1
End If
Next

End If

Next

'insertion of the animal-microorganism values for the products
For counter2 = 1 To Telrecords("Animal-MicroOrganisms")
Sheet3.Activate
If ActiveSheet.Cells(counter2, 1).Value = Value1 Then
Sheet8.Activate
Range(Cells(counter + 1, 1), Cells(counter + 1, 1)).Select
ActiveCell.EntireRow.Insert shift:=xlDown
C = C + 1
Sheet3.Activate
Range(Cells(counter2, 3), Cells(counter2, 5)).Copy
Sheet8.Activate
Range(Cells(counter + 1, 8), Cells(counter + 1, 8)).PasteSpecial
Sheet3.Activate
Range(Cells(counter2, 8), Cells(counter2, 9)).Copy
Sheet8.Activate
Range(Cells(counter + 1, 11), Cells(counter + 1, 11)).PasteSpecial
counter = counter + 1
End If
Next
Next
End Sub

Function Telrecords(Worksheet As String) As Integer



Dim A As Integer
Dim B As Integer

A = 1
B = 0
Do
If Worksheets(Worksheet).Cells(A, 1) = "" Then
B = 1
Else
A = A + 1
End If
Loop Until B = 1

Telrecords = A
'MsgBox (A)
End Function

matthewspatrick
07-27-2006, 07:34 AM
sandero,

Please do the following:

Edit your original post, select the VBA code, and hit the VBA button in the editor. That will apply VBA tags, and make your code easier for us to read.
Please desribe in a few sentences what your code is supposed to do
Please supply an example file

ALe
07-27-2006, 10:11 AM
the problems with your code are:

1. the function creates a time-consuming loop

instead of your function try something like this
C = Worksheets("Products").Range("a65000").End(xlUp).Row + 1

2. there're too many activate/select
Most of the times you don't need them
for example
Sheet1.Activate
Range(Cells(1, 2), Cells(C, 2)).Copy

can be done without sheet activation (and the same for past)
Sheet1.Range(Sheet1.Cells(1, 2), Sheet1.Cells(C, 2)).Copy

etc...

Bob Phillips
07-27-2006, 11:59 AM
The other problem is that you are not fully qualifying objects, and with the leaping from sheet to sheet (makes you sound like a lady of the night), you could well be referencing the wrong one.

I recut your code to this, but take a backup and test it well because, guess what, I didn't.



Option Explicit

Sub test()
'define number of records in products
Dim C As Long
Dim counter As Long
Dim counter1 As Long
Dim counter2 As Long
Dim counter3 As Long
Dim Value1 As String
Dim Value2 As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

C = Worksheets("Products").Range("A1").End(xlDown).Row

'copy of required product attributes to the other worksheet
With Sheet1
.Range(.Cells(1, 2), .Cells(C, 2)).Copy Sheet8.Range("A1")
.Range(.Cells(1, 6), .Cells(C, 6)).Copy Sheet8.Range("B1")
.Range(.Cells(1, 9), .Cells(C, 11)).Copy Sheet8.Range("C1")
.Range(.Cells(1, 19), .Cells(C, 19)).Copy Sheet8.Range("F1")
End With
'end of copy

'testing insert rows
'For counter = 4 To (Telrecords("Sheet1")) * 2 Step 2
'Range(Cells(counter - 1, 1), Cells(counter - 1, 1)).Select
'ActiveCell.EntireRow.Insert shift:=xlUp
'Next

'For counter = 2 To (Telrecords("Products") + Telrecords("Product-Component") + Telrecords("Animal-MicroOrganisms"))
For counter = 20 To 25

'For counter = 2 To C
Value1 = Worksheets("Sheet1").Cells(counter, 1).Value

'insertion of the components and their animal-microorganism values
For counter1 = 1 To Worksheets("Product-Component").Range("A1").End(xlDown).Row
If Sheet2.Cells(counter1, 1).Value = Value1 Then
Sheet8.Rows(counter + 1).Insert
C = C + 1
Sheet2.Cells(counter1, 2).Copy Sheet8.Cells(counter + 1, 7)
counter = counter + 1
Value2 = Worksheets("Product-Component").Cells(counter1, 2).Value

For counter3 = 1 To Worksheets("Animal-MicroOrganisms").Range("A1").End(xlDown).Row
If Sheet3.Cells(counter3, 1).Value = Value2 Then
Sheet8.Rows(counter + 1).Insert
C = C + 1
Sheet3.Cells(counter3, 3).Resize(1, 3).Copy _
Sheet8.Cells(counter + 1, 8)
Sheet3.Cells(counter3, 8).Resize(1, 2).Copy _
Sheet8.Cells(counter + 1, 11)
counter = counter + 1
End If
Next counter3

End If

Next counter1

'insertion of the animal-microorganism values for the products
For counter2 = 1 To Worksheets("Animal-MicroOrganisms").Range("A1").End(xlDown).Row
If Sheet3.Cells(counter2, 1).Value = Value1 Then
Sheet8.Rows(counter + 1, 1).Insert
C = C + 1
Sheet3.Cells(counter2, 3).Resize(1, 3).Copy _
Sheet8.Cells(counter + 1, 8)
Sheet3.Cells(counter2, 8).Resize(1, 2).Copy _
Sheet8.Cells(counter + 1, 11)
counter = counter + 1
End If

Next counter2

Next counter

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

sandero
07-27-2006, 03:41 PM
thx a lot guys,

i'll test it first thing in the morning,

better get to sleep though :)
cheers,
sander

sandero
07-27-2006, 11:51 PM
nevermind :)