This function conditionally copies and pastes information from one sheet to another based on the column headings to standardize data before exported to SQL database.

I am not an expert in VBA and started learning but when I run this code, it takes way too long to process huge data (ex: Excel sheet with 70k rows would take like 2 minutes to 5 minutes). Can anyone make a suggestion to make it time-efficient?

Option Explicit

Public Sub projectionTemplateFormat()

    Dim t1 As Double, t2 As Double

    xlSpeed True

        t1 = Timer
        'On Error Resume Next
        'On Error GoTo 0
        t2 = Timer

    xlSpeed False

    MsgBox "Duration: " & t2 - t1 & " seconds"

End Sub

Private Sub mainProcess()

    Const SPACE_DELIM   As String = " "

    Dim wsIndex             As Worksheet
    Dim wsImport            As Worksheet    'Raw
    Dim wsFinal             As Worksheet

    Dim indexHeaderCol      As Range
    Dim msg                 As String

    Dim importHeaderRng     As Range
    Dim importColRng        As Range
    Dim importHeaderFound   As Variant
    Dim importLastRow       As Long

    Dim finalHeaderRng      As Range
    Dim finalColRng         As Range
    Dim finalHeaderRow      As Variant
    Dim finalHeaderFound    As Variant
    Dim header              As Variant      'Each item in the FOR loop
    Dim lastRow As Long  'Manual Headers based on the number of rows in the raw data
    Dim rngs As Range

    Set wsIndex = aIndex    'This is the Code Name; top-left pane: aIndex (Index)
    Set wsImport = bImport  'Direct reference to Code Name: bImport.Range("A1")
    Set wsFinal = cFinal    'Reference using Sheets collection: ThisWorkbook.Worksheets("Final")
    Set rngs = ThisWorkbook.Sheets("DATA").Cells

    lastRow = rngs.Find(What:="*", After:=rngs.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row + 1
    '+ 1 is added for dummy row in the final sheet; otherwise it won't copy the last row in the import sheet

    'Static Data(Account Level information)
    wsFinal.Range("D3:D" & lastRow).Value = Sheets("INDEX").Range("H2").Value
    wsFinal.Range("AD3:AD" & lastRow).Value = Sheets("INDEX").Range("H3").Value
    wsFinal.Range("X3:X" & lastRow).Value = Sheets("INDEX").Range("H4").Value
    wsFinal.Range("Y3:Y" & lastRow).Value = Sheets("INDEX").Range("H5").Value
    wsFinal.Range("AF3:AF" & lastRow).Value = Sheets("INDEX").Range("H6").Value
    wsFinal.Range("AG3:AG" & lastRow).Value = Sheets("INDEX").Range("H7").Value
    wsFinal.Range("AE3:AE" & lastRow).Value = Sheets("INDEX").Range("H8").Value
    wsFinal.Range("F3:F" & lastRow).Value = Sheets("INDEX").Range("H9").Value
    wsFinal.Range("AC3:AC" & lastRow).Value = Sheets("INDEX").Range("H10").Value

    'Claim Type
    wsFinal.Range("E3:E" & lastRow).Value = "AB"

    With wsImport.UsedRange
        Set importHeaderRng = .Rows(1)      'Import - Headers
        importLastRow = .Rows.Count + 1         'Import - Total Rows; + 1 is for taking into consideration of the dummy row in the final sheet
    End With

    With wsFinal.UsedRange
        finalHeaderRow = .Rows(1)           'Final - Headers (as Array)
        Set finalHeaderRng = .Rows(1)       'Final - Headers (as Range)
    End With

    With wsIndex.UsedRange  'Transpose col 3 from Index (without the header), as column names in Import
        Set indexHeaderCol = .Columns(3).Offset(1, 0).Resize(.Rows.Count - 1, 1)
        wsImport.Range(wsImport.Cells(1, 1), wsImport.Cells(1, .Rows.Count - 1)).Value2 = Application.Transpose(indexHeaderCol)
    End With

    If Len(aIndex.Cells(1, 1).Value2) > 0 Then 'if index cell (1,1) is not empty

        With Application

            For Each header In finalHeaderRow   'Loop through all headers in Final

                If Len(Trim(header)) > 0 Then   'If the Final heade is not empty

                    importHeaderFound = .Match(header, importHeaderRng, 0)          'Find header in Import sheet

                    If IsError(importHeaderFound) Then
                        msg = msg & vbLf & header & SPACE_DELIM & wsImport.Name     'Import doesn't have current header

                        finalHeaderFound = .Match(header, finalHeaderRng, 0)        'Find header in Final sheet

                        If IsError(finalHeaderFound) Then
                            msg = msg & vbLf & header & SPACE_DELIM & wsFinal.Name  'Import doesn't have current header

                            With wsImport
                                Set importColRng = .UsedRange.Columns(importHeaderFound).Offset(1, 0).Resize(.UsedRange.Rows.Count - 1, 1)
                            End With

                            With wsFinal
                                Set finalColRng = .Range(.Cells(3, finalHeaderFound), .Cells(importLastRow, finalHeaderFound)) 'Change 3 to 2 if the dummy row is not included
                                finalColRng.Value2 = vbNullString                   'Delete previous values (entire column)
                            End With

                            finalColRng.Value2 = importColRng.Value2             'Copy Import data in Final columns

                        End If
                    End If
                End If
            Next header
        End With

Dim i As Long
       For i = 3 To lastRow

          If Not (wsFinal.Cells(i, "Q").Value <= 2015 And wsFinal.Cells(i, "Q").Value >= 1910) Then
            With wsFinal
                .Cells(i, "Q").ClearContents
            End With

          End If
       Next i

       Dim j As Long
          For j = 3 To lastRow

          If Not (wsFinal.Cells(j, "R").Value <= 2015 And wsFinal.Cells(j, "R").Value >= 1910) Then
            With wsFinal
                .Cells(j, "R").ClearContents
            End With

          End If

       Next j

          wsFinal.Columns("G").NumberFormat = "@"
          wsFinal.Columns("I").NumberFormat = "MM/DD/YYYY"
          wsFinal.Columns("K").NumberFormat = "MM/DD/YYYY"
          wsFinal.Columns("A").NumberFormat = "@"
          wsFinal.Columns("B").NumberFormat = "@"
          wsFinal.Columns("C").NumberFormat = "@"
          'wsFinal.Columns("R").NumberFormat = "@"
          'wsFinal.Columns("Q").NumberFormat = "@"
          wsFinal.Columns("J").NumberFormat = "@"
          wsFinal.Columns("L").NumberFormat = "@"
          wsFinal.Columns("T").NumberFormat = "MM/DD/YYYY"
          wsFinal.Columns("W").NumberFormat = "MM/DD/YYYY"
          wsFinal.Columns("V").NumberFormat = "MM/DD/YYYY"
          wsFinal.Columns("AD").NumberFormat = "MM/DD/YYYY"
          wsFinal.Columns("N").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
          wsFinal.Columns("AN").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
          wsFinal.Columns("AO").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
          wsFinal.Columns("AP").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
          'wsFinal.Columns("AQ").NumberFormat = "General"

 applyFormat wsFinal.Range(wsFinal.Cells(2, 1), wsFinal.Cells(importLastRow, wsFinal.UsedRange.Columns.Count))

    Dim ws As Worksheet
       For Each ws In Worksheets
       ActiveWindow.Zoom = 90
    Next ws

        MsgBox "Missing raw data (Sheet 2 - 'Import')", vbInformation, "   Missing Raw Data"
    End If

End Sub

Function 2

 Private Sub extractYears()

        Dim arr As Variant, i As Long, j As Long, ur As Range, colW As Long, colV As Long

        Set ur = cFinal.UsedRange                   '3rd sheet

        If WorksheetFunction.CountA(ur) > 0 Then

            colW = colNum("Q")
            colV = colNum("R")

            arr = ur                                'transfer sheet data to memory

            For i = 3 To getMaxCell(ur).Row         'each "row"

                If Len(arr(i, colW)) > 0 Then       'if not empty
                    If Len(arr(i, colW)) > 4 Then   'if it's full date (longer than 4 digits)
                        arr(i, colW) = Format(arr(i, colW), "yyyy") 'extract the year part
                    End If
                End If                              'if it contains 4 digit year leave it as is

                If Len(arr(i, colV)) > 0 Then       'the same logic applied for colV
                    If Len(arr(i, colV)) > 4 Then
                        arr(i, colV) = Format(arr(i, colV), "yyyy")
                    End If
                End If

            ur = arr                                'transfer memory data back to sheet

        End If
    End Sub

Function 2

Private Sub applyFormat(ByRef rng As Range)
    With rng

        With .Font
            .Name = "Georgia"
            .Color = RGB(0, 0, 225)
        End With
        .Interior.Color = RGB(216, 228, 188)
        With .Rows(1)
            .Font.Bold = True
            .Interior.ColorIndex = xlAutomatic
        End With
        With .Borders
            .LineStyle = xlDot  'xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With

    End With

    refit rng
End Sub

Sub ConvertToUppercase()

   Dim ws As Object
   Dim LCell As Range

   'Move through each sheet in your spreadsheet

      On Error Resume Next

      'Convert all constants and text values to proper case
      For Each LCell In Cells.SpecialCells(xlConstants, xlTextValues)
         LCell.Formula = UCase(LCell.Formula)

End Sub
  • 3
    \$\begingroup\$ Its also good to provide us some context about what the code does. I'm much more likely to answer a question if I don't have to waste time figuring that out myself. \$\endgroup\$ – RubberDuck Jul 27 '15 at 21:51
  • \$\begingroup\$ Okay I might edit the original post \$\endgroup\$ – Bril Jul 27 '15 at 22:23
  • 1
    \$\begingroup\$ I could probably try if I could compile your project! What is xlSpeed? Could you also show the code where the, presumably, Public Variables aIndex, bImport and cFinal are declared and populated? A redacted copy of your sheets would be helpful too. \$\endgroup\$ – Mark Fitzgerald Jul 28 '15 at 10:05
  • 1
    \$\begingroup\$ Your first step should be to use the Timer function inside your mainProcess to work out which part of the code takes the most time - is it the main loop or the call to ConvertToUppercase or extractYears or the final loop. \$\endgroup\$ – ChipsLetten Jul 28 '15 at 16:47
  • \$\begingroup\$ I agree here with @MarkFitzgerald - what is xlspeed and are aIndex, bImport and cFinal placeholders for actual sheets? Some test data would also be useful. \$\endgroup\$ – Raystafarian Jul 29 '15 at 15:20

As has been mentioned in the Comments, it is difficult/impossible to offer specific suggestions without a more complete overview of the code/project/data.

However, I can offer a general piece of advice:

Put all your data in an array before you do anything to/with it.

Interacting directly with workbooks/sheets takes an order of magnitude (at least) more time than interacting with an array.

If you only have one point at the start when you put all the data into an array, and one point at the end where you paste the data from an array into the second worksheet, everything that happens in between should run an order of magnitude faster


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.