Faster Excel Macro

[rnordquest]

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

 

[onlyadrafter]

Hello,

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!

 

[onlyadrafter]

Hello,

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!

 

[rnordquest]

I had already taken care of the Screen Updating. I'm sure my problem is with the If checks, especially the 2nd. I'll see what I can do with what you proposed. One of my problems is not every cell in all 20 columns has something in it and it's not consistent either. That's what I'm trying to fix, i.e. to group everything by part number.

 

[rnordquest]

Your version took 10 min longer. It certainly looked faster anyway and I picked up some great techniques so your effort certainly wasn't wasted.

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

 

[MortenA]

If you have a large list of data where you wish to group by certain cell value you should look at a pivot table.

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

 

[johnwm]

Just a couple of general suggestions.

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:
[tt]
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"
[/tt]

Good Luck
johnwm
________________________________________________________
To get the best from these forums read faq731-376 before posting

 

[rnordquest]

Morten,

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

 

[rnordquest]

John,

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.

 

[MortenA]

wel in office 2000 you can make multiple ranges (havent used it myself so im not familiar with details).

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

 

[johnwm]

It works fine in Excel XP. Unfortunately I don't have a copy of 97 to test on. You could try replacing:

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

 

[schwarz]

Hi Roger,
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