VBA code taking too long to process

[Woofy_McWoof_Woof]

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.

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

 

[Rijnsent]

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:

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

 

[offthelip]

I don't have time to rewrite your code but have a look at this thread because your problem is exactly the smae and the solution is exactly the same: USE VARIANT ARRAYS:
https://www.mrexcel.com/forum/excel...nning-super-slow-post5293498.html#post5293498

 

[Woofy_McWoof_Woof]

Thank you both for your help, i will take a look at the thread and include the switching off the calculation etc.

 

[offthelip]

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.

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