Thread: How can I speed up this slow macro?

I have a 17,000 row excel 2007 spread sheet that looks like this:

PHP Code: 

   A         B      C       D         E         F         G        H
DATA    2000    2003    Isuzu    Trooper     DATA    DATA    DATA
DATA    1996    1999    Isuzu    Oasis       DATA    DATA    DATA
DATA    2003    2004    Isuzu    Ascender    DATA    DATA    DATA 


I want it to look more like this:

PHP Code: 

   A         B      C       D         E         F         G        H
DATA    2000            Isuzu    Trooper     DATA    DATA    DATA
DATA    2001            Isuzu    Trooper     DATA    DATA    DATA
DATA    2002            Isuzu    Trooper     DATA    DATA    DATA
DATA    2003            Isuzu    Trooper     DATA    DATA    DATA
DATA    1996            Isuzu    Oasis       DATA    DATA    DATA
DATA    1997            Isuzu    Oasis       DATA    DATA    DATA
DATA    1998            Isuzu    Oasis       DATA    DATA    DATA
DATA    1999            Isuzu    Oasis       DATA    DATA    DATA
DATA    2003            Isuzu    Ascender    DATA    DATA    DATA
DATA    2004            Isuzu    Ascender    DATA    DATA    DATA 


PHP Code: 

Here is the macro I created to do this:

Dim year1 As Integer
Dim year2 As Integer
Dim counter As Integer
Range("B1").Select

Do While Not IsEmpty(ActiveCell)

ActiveCell.Offset(1, 0).Select
year1 = ActiveCell.Value
year2 = ActiveCell.Offset(0, 1).Value
counter = year2 - year1
ActiveCell.Offset(0, 1).Value = ""

Do While counter > 0
ActiveCell.EntireRow.Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = ActiveCell.Value + 1
counter = counter - 1
Loop

Loop
End Sub 


The problem is that after the first 100 or so lines the macro slows down to 1 line every 1 second. After 400 lines is slows to 1 line every 2 seconds. I am guessing that I will have around 300,000 lines after everything is said and done. At the rate this thing is running it will take a year to finish. Is there a better way to acomplish what I need?

Hi

See if this is any faster.

Sub aaa()
  For i = Cells(Rows.Count, 1).End(xlUp).Row + 1 To 2 Step -1
    cntr = Cells(i - 1, 3).Value - Cells(i - 1, 2).Value
    Cells(i, 1).Resize(cntr, 1).EntireRow.Insert shift:=xlDown
    Cells(i, 1).Resize(cntr, 1).Value = Cells(i - 1, 1).Value
    Cells(i, 4).Resize(cntr, 5).Value = Cells(i - 1, 4).Resize(1, 5).Value
    For j = 0 To cntr - 1
      Cells(i + j, 2).Value = Cells(i - 1, 2).Value + j + 1
    Next j
  Next i
  Range("C:C").ClearContents
End Sub

rylo

Sub test()
Dim a, b(), i As Long, ii As long, iii As Long, n As Long
a = Range("a1").CurrentRegion.Value
ReDim b(1 To Rows.Count, 1 To UBound(a,2))
For i = 1 To UBound(a,1)
    For ii = a(i,2) To a(i,3)
        n = n + 1
        For iii = 1 To UBound(a,1)
            If iii <> 3 Then b(n,iii) = a(i, IIf(iii=2, ii, iii))
        Next
    Next
Next
Range("a1").Resize(n, UBound(b,2)).Value = b
End Sub

Originally Posted by rylo

Hi

See if this is any faster.

Sub aaa()
  For i = Cells(Rows.Count, 1).End(xlUp).Row + 1 To 2 Step -1
    cntr = Cells(i - 1, 3).Value - Cells(i - 1, 2).Value
    Cells(i, 1).Resize(cntr, 1).EntireRow.Insert shift:=xlDown
    Cells(i, 1).Resize(cntr, 1).Value = Cells(i - 1, 1).Value
    Cells(i, 4).Resize(cntr, 5).Value = Cells(i - 1, 4).Resize(1, 5).Value
    For j = 0 To cntr - 1
      Cells(i + j, 2).Value = Cells(i - 1, 2).Value + j + 1
    Next j
  Next i
  Range("C:C").ClearContents
End Sub

rylo

Thank you,

I tried this out and got the following error:

Run-time error '1004':

Application-defined or object-defined error.

Any ideas?

Originally Posted by jindon

Sub test()
Dim a, b(), i As Long, ii As long, iii As Long, n As Long
a = Range("a1").CurrentRegion.Value
ReDim b(1 To Rows.Count, 1 To UBound(a,2))
For i = 1 To UBound(a,1)
    For ii = a(i,2) To a(i,3)
        n = n + 1
        For iii = 1 To UBound(a,1)
            If iii <> 3 Then b(n,iii) = a(i, IIf(iii=2, ii, iii))
        Next
    Next
Next
Range("a1").Resize(n, UBound(b,2)).Value = b
End Sub

Thank you,

I tried this one out and received the following error:

Run-time error '7':

Out of memory


If it makes any difference I running this on a dual XEON machine with 2 GB of RAM with 32 bit XP.

Hi

I put your example data into the range A1:H3, then copied it down until row 10000.

Ran my code, and it didn't give any errors, and completed in about 1 min.

How about you put up an example workbook, with data that causes an error. Make sure it is in 2003 format, not 2007

rylo

try
It should finish within a second.

Sub test()
Dim a, b(), i As Long, ii As long, iii As Long, n As Long
a = Range("a1").CurrentRegion.Resize(,8).Value
ReDim b(1 To 30000, 1 To 8)
For i = 1 To UBound(a,1)
    For ii = a(i,2) To a(i,3)
        n = n + 1
        For iii = 1 To UBound(a,1)
            If iii <> 3 Then b(n,iii) = a(i, IIf(iii=2, ii, iii))
        Next
    Next
Next
Range("a1").Resize(n, UBound(b,2)).Value = b
End Sub