sassora
02-17-2012, 03:53 AM
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?
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
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?
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