Faster Excel Macro
Faster Excel Macro
(OP)
How can I speed up this section of my macro? I have enough data that this one part takes 45 min. endRow ~ 18,000. It just copies the part number into column A. Original data looks something like this:
Drawing 12345
abc
def
23456 23456
abc
junk
34567 34567
abc
Drawing 45678
=====
For k = 2 To endRow
Cells(k, 1).Activate
curCell = ActiveCell.Value
firstCh = Left(curCell, 1)
If ActiveCell.Value = "Drawing" Then
pn = ActiveCell.Offset(0, 1).Value
ElseIf firstCh = "1" Or _
firstCh = "2" Or _
firstCh = "3" Or _
firstCh = "4" Or _
firstCh = "5" Or _
firstCh = "6" Or _
firstCh = "7" Or _
firstCh = "8" Or _
firstCh = "9" Or _
firstCh = "M" Then
pn = ActiveCell.Value
End If
ActiveCell.Value = pn
Next k
=====
When finished it looks like this:
12345 12345
12345 abc
12345 def
23456 23456
23456 abc
23456
34567 34567
34567 abc
45678 45678
Drawing 12345
abc
def
23456 23456
abc
junk
34567 34567
abc
Drawing 45678
=====
For k = 2 To endRow
Cells(k, 1).Activate
curCell = ActiveCell.Value
firstCh = Left(curCell, 1)
If ActiveCell.Value = "Drawing" Then
pn = ActiveCell.Offset(0, 1).Value
ElseIf firstCh = "1" Or _
firstCh = "2" Or _
firstCh = "3" Or _
firstCh = "4" Or _
firstCh = "5" Or _
firstCh = "6" Or _
firstCh = "7" Or _
firstCh = "8" Or _
firstCh = "9" Or _
firstCh = "M" Then
pn = ActiveCell.Value
End If
ActiveCell.Value = pn
Next k
=====
When finished it looks like this:
12345 12345
12345 abc
12345 def
23456 23456
23456 abc
23456
34567 34567
34567 abc
45678 45678





RE: Faster Excel Macro
No idea if this makes a difference, let me know, there is probably an even better/quicker way.
Application.ScreenUpdating = False
For k = 2 To Range("A65536").End(xlUp).Row
'Cells(k, 1).Activate
'curCell = Cells(k, 1).Value
firstCh = Left(Cells(k, 1), 1)
If Cells(k, 1).Value = "Drawing" Then
pn = Cells(k, 1).Offset(0, 1).Value
ElseIf firstCh = "1" Or _
firstCh = "2" Or _
firstCh = "3" Or _
firstCh = "4" Or _
firstCh = "5" Or _
firstCh = "6" Or _
firstCh = "7" Or _
firstCh = "8" Or _
firstCh = "9" Or _
firstCh = "M" Then
pn = Cells(k, 1).Value
End If
Cells(k, 1).Value = pn
Next k
Application.ScreenUpdating = True
----------------------------------
Hope this helps.
----------------------------------
maybe only a drafter
but the best user at this company!
RE: Faster Excel Macro
Have come up with an alternative version, does this spped it up and is it still working as expected?
Application.ScreenUpdating = False
For k = 2 To Range("A65536").End(xlUp).Row
If IsEmpty(Cells(k, 1).Value) Then GoTo CONT
Range("G1").Value = Asc(Left(Cells(k, 1), 1))
If Cells(k, 1).Value = "Drawing" Then
pn = Cells(k, 1).Offset(0, 1).Value
Else
If Asc(Left(Cells(k, 1), 1)) >= 48 And Asc(Left(Cells(k, 1), 1)) <= 57 Or _
Asc(Left(Cells(k, 1), 1)) = 77 Then pn = Cells(k, 1).Value
End If
CONT:
Cells(k, 1).Value = pn
Next k
Application.ScreenUpdating = True
----------------------------------
Hope this helps.
----------------------------------
maybe only a drafter
but the best user at this company!
RE: Faster Excel Macro
RE: Faster Excel Macro
Most of the time I have to slightly modify code that gets written here. Your's worked perfectly. I must have done a better job describing what I needed than usual.
I found that 1/3 of the rows processed are completely blank. I'll have someone go in and delete them. That should cut down on the time considerably.
Roger
RE: Faster Excel Macro
If you are familiar with this feature of excel i wont bother you if not please post back and i will broaden.
Best regards
Morten
RE: Faster Excel Macro
1. Rather than re-evaluate the last row every time through the loop, do it once before the loop.
2. Only evaluate firstchr if you need to (test for "Drawing" first)
3. Use Select Case rather than multiple ElseIf...Or
4. To help optimise add a timer so you can see what's going on.
I've incorporated these suggestions here:
x = Timer
Application.ScreenUpdating = False
l = Range("A65536").End(xlUp).Row
For k = 2 To l
If Cells(k, 1).Value = "Drawing" Then
pn = Cells(k, 1).Offset(0, 1).Value
Else
firstch = Left(Cells(k, 1), 1)
Select Case firstch
Case 1 - 9, "M"
pn = Cells(k, 1).Value
End Select
End If
Cells(k, 1).Value = pn
Next k
Application.ScreenUpdating = True
y = Timer - x
MsgBox "Test took " & y & " secs"
Good Luck
johnwm
________________________________________________________
To get the best from these forums read FAQ731-376 before posting
RE: Faster Excel Macro
A pivot table is indeed just where I'm headed. Can I make a pivot table pull data from 8 separate files with 20+ worksheets each? If I can then I don't need this macro. I guess I assumed that all the data had to be on one worksheet. Obviously I've done very little with pivot tables.
Even then would a pivot table be able to associate line def with drawing 12345 in my example?
John,
I did use a time check but not Timer as you did. Much more elegant, thanks. I'll give this a try.
Roger
RE: Faster Excel Macro
I get a type mismatch error for the statement:
Case 1 - 9, "M"
I'm running Excel 97. I tried Case 1 To 9, "M" and it errored also.
RE: Faster Excel Macro
This function can be called from VB - so that initially you can use the workbooks and sheets collections to find all sheets and the insert that into the funtion call (providing that each page has the same input field.
Best regards
Morten
RE: Faster Excel Macro
Case 1 - 9, "M"
with
Case "1" - "9", "M"
You can also trim the odd microsecond by replacing:
pn = Cells(k, 1).Offset(0, 1).Value
with
pn = Cells(k, 2).Value
Good Luck
johnwm
________________________________________________________
To get the best from these forums read FAQ731-376 before posting
RE: Faster Excel Macro
I decided to give a hard look at this. I repeated your data in 20000 +rows in one worksheet, it takes about 2 seconds to organise with code given below. Have I overlooked anything?
I am using excel 2000 .
Application.ScreenUpdating = False
l = Range("A65536").End(xlUp).Row
For k = 2 To l
If Cells(k, 1).Offset(0, 1).Value = "" Then GoTo End1
' can use currentCell.EntireRow.Delete instead of GoTo End1
If Cells(k, 1).Value = "Drawing" Then
pn = Cells(k, 1).Offset(0, 1).Value
Else
firstch = Left(Cells(k, 1), 1)
'Select Case firstch
'Case 1 To 9, "M"
' use following two if if Case does not work
If Val(firstch) >= 1 And Val(firstch) <= 9 Then pn = Cells(k, 1).Value
If firstch = "M" Then pn = Cells(k, 1).Value
'End Select
End If
Cells(k, 1).Value = pn
End1:
Next k
Application.ScreenUpdating = True
y = Timer - x ' thanks john
MsgBox "Test took " & y & " secs "
You can also get rid of blank rows by serialising & sorting data before running any macro.
Use pivot tables after this organising . Look for help with 'consolidate multiple data ranges' to use data from many sheets.
best regards,
GK