Macro taking long time to execute.

[vinod9111]

Hi all,

Have to generate 640 files basis district name. The output sheets are formula based , they pull the data from input sheets. Mostly the sumifs formula is used. It takes almost 5 minutes to generate one single file. Perhaps with each change of district the calculation features takes time to populate the figures resulting in lot of time taken for file generation.

Below have posted the codes, request you to give your valuable input to speed up the macro.=


Sub multplrept()
Dim dist As Range, curwbk As Workbook, newwb As Workbook, filname As String, foldername As String, sh As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set curwbk = ActiveWorkbook
foldername = curwbk.Path & "" & "LBR"
MkDir foldername


For Each dist In Range("distlist")
[distname] = dist.Value
DoEvents


filname = Worksheets("disbursement").Range("M1").Value


Sheets(Array("LBR_2_U2", "LBR_3_U3", "LBR_3_U3_B", "Banking Statistics - 1", "Banking Statistics - 2", "Banking Statistics - 3", "Banking Statistics - 4", "Doubling of Agricultural Credit", "Gist for Meeting", "LBS-MIS")).Copy


Set newwb = ActiveWorkbook
For Each sh In ActiveWorkbook.Worksheets
With sh.UsedRange
.Value = .Value
End With
Next sh
Range("a1").Select
newwb.SaveAs foldername & "" & filname & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
newwb.Close False
curwbk.Activate




Next
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

Any help will be highly appreciated.

regards

Vinod

 

[bobsan42]

try like this:

Sub multplrept()
    Dim dist As Range, curwbk As Workbook, newwb As Workbook, filname As String, foldername As String, sh As Worksheet
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Set curwbk = ActiveWorkbook
    foldername = curwbk.Path & "" & "LBR"
    MkDir foldername
    
    For Each dist In Range("distlist")
        [distname] = dist.Value
        DoEvents
        filname = Worksheets("disbursement").Range("M1").Value


        Application.Calculation = xlCalculationManual
            Sheets(Array("LBR_2_U2", "LBR_3_U3", "LBR_3_U3_B", "Banking Statistics - 1", "Banking Statistics - 2", "Banking Statistics - 3", "Banking Statistics - 4", "Doubling of Agricultural Credit", "Gist for Meeting", "LBS-MIS")).Copy
    
            Set newwb = ActiveWorkbook
            For Each sh In newwb.Worksheets
                With sh.UsedRange
                     .Value = .Value
                End With
            Next sh
            newwb.SaveAs foldername & "" & filname & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            newwb.Close False
            curwbk.Activate
        Application.Calculation = xlCalculationAutomatic
    Next
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

still depending on the amount of information the process may take some time. Did you try to make it manually for 1 file and try to time it?
I am not 100% sure but I think you can remove DoEvents to save some more time.

 

[vinod9111]

Hi Bobsan42,

Thanks for your help, with your suggested changes time has come down from 6 minutes to 1.5 minutes for generation of file.

It will save considerable time. The file is bulky,probably it is taking more time.

Regards,

Vinod