VBA code taking too long to process
Results 1 to 5 of 5

Thread: VBA code taking too long to process

  1. #1
    New Member
    Join Date
    Oct 2016
    Posts
    20
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default VBA code taking too long to process

    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 Fluff; Jul 15th, 2019 at 11:24 AM. Reason: Added code tags

  2. #2
    Board Regular Rijnsent's Avatar
    Join Date
    Oct 2005
    Location
    Utrecht, Holland
    Posts
    1,018
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA code taking too long to process

    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
    You can't post attachments here, but you can help me helping you by posting a screen shot directly in your post with any of those tools.
    Otherwise use dropbox/google drive/etc to get your file accross (not preferred). For code, put it inside these tags: [ CODE][/CODE]. Do check the forum rules.
    Finally, please show that you made an effort to solve your problem: Yes, I like to help, but am not going to do your job.

  3. #3
    Board Regular
    Join Date
    Dec 2017
    Location
    UK
    Posts
    837
    Post Thanks / Like
    Mentioned
    35 Post(s)
    Tagged
    1 Thread(s)

    Default Re: VBA code taking too long to process

    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-...ml#post5293498
    Last edited by offthelip; Jul 17th, 2019 at 11:49 AM.
    Speed up your code use variant arrays and NEVER ACCESS THE WORKSHEET IN A LOOP

  4. #4
    New Member
    Join Date
    Oct 2016
    Posts
    20
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA code taking too long to process

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

  5. #5
    Board Regular
    Join Date
    Dec 2017
    Location
    UK
    Posts
    837
    Post Thanks / Like
    Mentioned
    35 Post(s)
    Tagged
    1 Thread(s)

    Default Re: VBA code taking too long to process

    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 by offthelip; Jul 18th, 2019 at 09:07 AM.
    Speed up your code use variant arrays and NEVER ACCESS THE WORKSHEET IN A LOOP

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •