Problem with Code SLowing down

Lynxador

Board Regular
Joined
Jan 6, 2005
Messages
125
i have this code right here...

Code:
Sub Template_builder()

Dim Lastrow, X As Integer

'This function looks for the last row
Lastrow = Range("A65536").End(xlUp).Row

For X = Lastrow + 1 To 12 Step -1
Range("A5:H10").Select
Selection.copy
Range("A" & X & ":A" & X + 5).Select
Selection.Insert Shift:=xlDown
Next X
End Sub

It basically copys the template found at a1 through h10 and copies it to customer i have in teh excel sheet. The problem i am having.. is after... what, maybe 1000-1500 customers it slows waaaaaaaay down. any way i can fix that?
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Hi L,

You can usually speed things up a bit by switching off screenpdating and switching calculation to manual. You should also avoid using Select or Activate where possible - its rarely necessary and just slows down your code.

Something like this perhaps?
Code:
Sub Template_builder()
    Dim Lastrow As Long, X As Long
    Dim lCalc As Long
    
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    'This function looks for the last row
    With ThisWorkbook.Worksheets("Sheet1")
        Lastrow = .Range("A65536").End(xlUp).Row
        For X = Lastrow + 1 To 12 Step -1
            .Range("A5:H10").Copy
            .Range("A" & X & ":A" & X + 5).Insert Shift:=xlDown
        Next X
    End With
    
    With Application
        .Calculation = lCalc
        .ScreenUpdating = True
    End With
    
End Sub
HTH
 
Upvote 0
it just sits there.. tried tinkering around with it. made sure my sheets where named correctly and it still doesn't work
 
Upvote 0
I only shaved off a couple seconds (using 100 records), but I think it looks a lot better (essentially four lines of code versus 6):

Code:
Sub Template_builder()
Dim X As Long
    
    Application.ScreenUpdating = False
    
    For X = Range("A65536").End(xlUp).Row + 1 To 12 Step -1
        Range("A5:H10").Copy
        Range("A" & X).Resize(6).Insert Shift:=xlShiftDown
    Next X
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

I also didn't see a significant improvement changing calculation to manual (the time was the same to 11 or 12 decimal places).
 
Upvote 0
Here's a solution that takes .001 of a second for 1000 records :wink:

The reason for this being fast is that is doesn't do any inserts or alot of copies.
-It creates a new sheet
-works out how many times the template info needs to be copied to the new sheet
- 1 Copy to copy template N times ... all at once
- Fill in the blanks above each template with the unique data that was below the original template

ASSUMPTIONS:
1. Row 4 is empty :eek:
2. The data to add to template starts in row 11 ( just below info to be copied) :eek:


Public Sub CopyTemplateV2()
Dim SrcSh As Worksheet
Set SrcSh = ActiveSheet


Application.ScreenUpdating = False

'Calculate how many copies need
TopRw = 11
BotRw = SrcSh.Range("A65536").End(xlUp).Row
TotRws = BotRw - TopRw + 1
PasteRws = TotRws * 7

' do all copies at once including a space
'above each ie. row 4 MUST BE EMPTY
SrcSh.Range("A4:H10").Copy
Sheets.Add
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1:H" & PasteRws)

'Fill in the unique data in spaces left for it
rw = 1
For r = 1 To TotRws
ScrRw = TopRw + LoopCnt
Range("A" & rw & ":H" & rw).Value = SrcSh.Range("A" & ScrRw & ":H" & ScrRw).Value
rw = rw + 7
LoopCnt = LoopCnt + 1
Next r

Application.ScreenUpdating = True

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,236
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top