VBA code taking too long to process

Woofy_McWoof_Woof

New Member
Joined
Oct 7, 2016
Messages
40
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:

Some videos you may like

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

Rijnsent

Well-known Member
Joined
Oct 17, 2005
Messages
1,275
Office Version
365
Platform
Windows
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
 

Woofy_McWoof_Woof

New Member
Joined
Oct 7, 2016
Messages
40
Thank you both for your help, i will take a look at the thread and include the switching off the calculation etc.
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,259
Office Version
2010
Platform
Windows
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:

Watch MrExcel Video

Forum statistics

Threads
1,101,819
Messages
5,483,087
Members
407,379
Latest member
Bender1964

This Week's Hot Topics

  • Finding issue in If elseif else with For each Loop
    Finding issue in If elseif else with For each Loop I have tried this below code but i'm getting in Y column filled with W005. Colud you please...
  • MsgBox Error
    Hi Guys, I have the below error show up when i try and run my macro in File1 but works fine if i copy and paste the same code into file2. [ATTACH...
  • CELL FORMAT - IF CONDITION
    My Cell Format is [B]""0.00" Cr". [/B]But in the cell, it is showing 123.00 for editing. (123 is entry figure). (Data imported from other...
  • Show numbers nearly the same
    Is this possible. I have a number that can change very time eg 0.00001234 Then I have a lot of numbers 0.0000001, 0.0000002, 0.00000004...
  • Please i need your help to create formula
    I need a formula in cell B8 to do this >>if b1=1 then multiply ( cell b8) by 10% ,if b1=2 multiply by 20%,if=3 multiply by 30%. Thank you in...
  • Got error while adding column and filter
    Got error while adding column and filter In column Z has some like "Success" and "Error". I want to add column in AA if the Z cell value is...
Top