VBA code taking too long to process

Woofy_McWoof_Woof

Board Regular
Joined
Oct 7, 2016
Messages
60
Office Version
  1. 365
Platform
  1. Windows
Hi, I have a macro that copies data into a separate sheet (after converting a matrix to string for three columns - date, time and value). It works fine apart from the fact it takes too long (approximately 5 minutes) to copy across. Although there is a large amount of data is there a way of speeding this up? I'm converting about three years of HH data.





Code:
Option Explicit
 
Private SheetCount As Integer
Private Const New_Name = "Keyed"


Sub Make_Column()


' To create column from square (356*48) data


Dim HH As Long
Dim In_Row As Long
Dim Out_Row As Long
Dim Settlement_Date As Date
Dim ws As Worksheet


    SheetCount = 0
    On Error Resume Next
    
    ' Get rid of any keyed sheets that already exists
    
    For Each ws In Worksheets
        If Left$(ws.Name, Len(New_Name)) = New_Name Then
            ws.Delete
    End If
    
    Next
        
    Set ws = NewSheet
    In_Row = 2
    Out_Row = 1
      
    'Copy the data to the new sheet
    Do While Trim(Sheets("Data").Cells(In_Row, 1).Value) <> ""
        For HH = 1 To 48
            Out_Row = Out_Row + 1
            If Out_Row = 100000 Then
                Out_Row = 1
                Set ws = NewSheet
            End If
            With ws
                .Cells(Out_Row, 1) = Sheets("Data").Cells(In_Row, 1)
                .Cells(Out_Row, 2) = HH
                .Cells(Out_Row, 3) = Sheets("Data").Cells(In_Row, HH + 2)
            End With
        Next
        For HH = 49 To 50
            If Sheets("Data").Cells(In_Row, HH + 2) <> "" Then
                Out_Row = Out_Row + 2
                If Out_Row = 100000 Then
                    Out_Row = 1
                    Set ws = NewSheet
                End If
                With ws
                    .Cells(Out_Row, 1) = Sheets("Data").Cells(In_Row, 1)
                    .Cells(Out_Row, 2) = HH
                    .Cells(Out_Row, 3) = Sheets("Data").Cells(In_Row, HH + 2)
                End With
            End If
        Next
        
            
        In_Row = In_Row + 1
    Loop


End Sub


Private Function NewSheet() As Worksheet


    Sheets.Add After:=Worksheets(Worksheets.Count) ' Add new sheet for keyed data
    Set NewSheet = Sheets(Worksheets.Count)
    With NewSheet
        .Cells(1, 1).Value = "Date"
        .Cells(1, 2).Value = "HH"
        .Cells(1, 3).Value = "Data"
        .Columns("A:A").NumberFormat = "dd-mmm-yy"
        .Columns("A:A").ColumnWidth = 16
        .Columns("B:B").ColumnWidth = 4
        .Columns("C:D").NumberFormat = "#,##0.00"
        .Columns("C:D").ColumnWidth = 11
    
        SheetCount = SheetCount + 1
        If SheetCount = 1 Then
            .Name = New_Name
        Else
            .Name = New_Name & " " & SheetCount
        End If
    
    End With
    
End Function




Thanks in advance for any help.
Cheers
Woof
 
Last edited by a moderator:

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Hi Woof,
to speed macros up, you could try starting them by switching off auto calculation, screenupdating and events and switching those back on again at the end of your macro:

Code:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

'And at the end of your code:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Hope that helps,
Koen
 
Upvote 0
Thank you both for your help, i will take a look at the thread and include the switching off the calculation etc.
 
Upvote 0
I have made an effort to recode you program using variant arrays, it is totally untested and I can almost guaranteee it won't work, but it should give you the idea as to how to go about it.
Code:
Sub test()
Option Explicit
 
Private SheetCount As Integer
Private Const New_Name = "Keyed"




Sub Make_Column()




' To create column from square (356*48) data




Dim HH As Long
Dim In_Row As Long
Dim Out_Row As Long
Dim Settlement_Date As Date
Dim ws As Worksheet




    SheetCount = 0
    On Error Resume Next
    
    ' Get rid of any keyed sheets that already exists
    
    For Each ws In Worksheets
        If Left$(ws.Name, Len(New_Name)) = New_Name Then
            ws.Delete
    End If
    
    Next
        
    Set ws = NewSheet
    In_Row = 2
    Out_Row = 1
     With worksSheets("Data")
      lastrow = .Cells(Rows.Count, "A").End(xlUp).Row ' find last row with data in it
      inarr = Range(Cells(1, 1), Cells(lastrow, 52)) ' load the entire Data worksheet into a variant array
      Dim outarr(1 To 53, 1 To 52) As Variant   ' define output array 53 rows by 52 columns
    'Copy the data to the new sheet
    Do While Trim(inarr(In_Row, 1)) <> ""
           outstart = outrow
        For HH = 1 To 48
            Out_Row = Out_Row + 1
            If Out_Row = 100000 Then
                 'write out the output array
                With ws
                 Range(.Cells(outstart, 1), Cells(outrow, 3)) = outarr
                End With
                outstart = 1
                Out_Row = 1
                Set ws = NewSheet
            End If
                outarr(Out_Row, 1) = inarr(In_Row, 1)
                outarr(Out_Row, 2) = HH
                outarr(Out_Row, 3) = inarr(In_Row, HH + 2)
        Next
             'write out the output array
            With ws
             Range(.Cells(outstart, 1), Cells(outrow, 3)) = outarr
            End With
            outstart = outrow
        For HH = 49 To 50
            If inarr(In_Row, HH + 2) <> "" Then
                Out_Row = Out_Row + 2
                If Out_Row = 100000 Then
                    'write out the output array
                    With ws
                     Range(.Cells(outstart, 1), Cells(outrow, 3)) = outarr
                    End With
                    outstart = 1
                    Out_Row = 1
                    Set ws = NewSheet
                End If
                outarr(Out_Row, 1) = inarr(In_Row, 1)
                outarr(Out_Row, 2) = HH
                outarr(Out_Row, 3) = inarr(In_Row, HH + 2)
            End If
        Next
        
            
        In_Row = In_Row + 1
    Loop




End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,192
Members
448,554
Latest member
Gleisner2

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