Can anyone make this more efficient?

[sassora]

I have a list of publications which have categories a,b and c in the same row.

The code below changes the list from

publication.doc a b c

to

publication.doc a
publication.doc b
publication.doc c

It's running slow, can you help?


[VBA]
Sub DuplicateforCategory_subprogramme()
Dim copyrow, pasterow, catnum, cnt(1 To 1000000), firstcopyrow, lastcopyrow As Integer
Dim shcopy, shpaste As Worksheet
Set shcopy = Worksheets("Catalogue")
Set shpaste = Worksheets("Subprogramme list")
firstcopyrow = 3
lastcopyrow = shcopy.Range("A" & Rows.Count).End(xlUp).Row
pasterow = firstcopyrow
Application.ScreenUpdating = False
shcopy.EnableCalculation = False
shpaste.EnableCalculation = False
For copyrow = 3 To lastcopyrow
'Number of categories used for a given document
cnt(copyrow) = shcopy.Range("C" & copyrow, "E" & copyrow).SpecialCells(xlCellTypeConstants).Count
For catnum = 1 To cnt(copyrow)

shcopy.Range("A" & copyrow & ":" & "B" & copyrow).Copy
shpaste.Range("A" & pasterow).PasteSpecial xlPasteValues

shcopy.Cells(copyrow, 3 + catnum - 1).Copy
shpaste.Range("C" & pasterow).PasteSpecial xlPasteValues

shcopy.Range("I" & copyrow & ":" & "J" & copyrow).Copy
shpaste.Range("D" & pasterow).PasteSpecial xlPasteValues

pasterow = pasterow + 1
Next catnum

Next copyrow
Application.ScreenUpdating = True
shcopy.EnableCalculation = True
shpaste.EnableCalculation = True
End Sub
[/VBA]

[Bob Phillips]

This runs about 6 times faster in my tests

[vba]


Sub DuplicateforCategory_subprogramme()
Dim copyrow As Long, firstcopyrow As Long, lastcopyrow As Long
Dim shcopy As Worksheet, shpaste As Worksheet

Application.ScreenUpdating = False

Set shcopy = Worksheets("Catalogue")
Set shpaste = Worksheets("Subprogramme list")

shcopy.EnableCalculation = False
shpaste.EnableCalculation = False

firstcopyrow = 3
lastcopyrow = shcopy.Range("A" & shcopy.Rows.Count).End(xlUp).Row
With shcopy

For copyrow = lastcopyrow To firstcopyrow Step -1

.Cells(copyrow, "A").Copy shpaste.Cells((copyrow - firstcopyrow + 1) * 3, "A").Resize(3)
.Cells(copyrow, "B").Resize(, 3).Copy
shpaste.Cells((copyrow - firstcopyrow + 1) * 3, "B").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Next copyrow
End With

Application.ScreenUpdating = True
shcopy.EnableCalculation = True
shpaste.EnableCalculation = True
End Sub
[/vba]

[sassora]

Thanks xld,

Something that I should have mentioned beforehand was that not all three categories have to be specified, i.e. they can be null, if this is the case then I don't need their information to be duplicated.

Is there a way to tweak the code to leave out such cases?