Super slow VBA code on Intel Core i7 with Max RAM

[netgroover]

I'm self taught Excel vba coder writer, and still learning.

I wrote a macro to import data that is in a new format, into separate tabs in a spreadsheet, reassigning the fields where necessary. The good news is that it works, the bad news is that importing a mere 300 records takes over 24 hours. It starts out by taking about a minute per record, which is excruciatingly slow, but as the processing continues, about 75% the way through it takes over 12 minutes to import a single record.

I've obviously bungled this somehow, as I'm amazed with the power of computing that such a simple task is more than Excel can handle (with my code, below). Any help appreciated, but in general, why is this so stinking slow? Is it because I'm using worksheet.function functions? Offset references? I'm stumped.

-- Thanks, Mark

Sub Import_Revinate()

Dim survey_id As String
Dim prop(1 To 8) As String
Dim indexcol As Integer
Dim import_recs As Integer
Dim tf As Boolean
Dim x As Integer
Dim y As Integer
Dim rec_check As String
Dim rec_row As Integer
Dim add_rec_row As Integer
Dim s_rec_count As Integer
Dim h_rec_count As Integer
Dim pos As Integer
Dim h_array_vals As String
Dim s_array_vals As String
Dim teststr As String
Dim donepct As Double
Dim donestr As String

Application.Calculation = xlCalculationManual

Application.EnableEvents = False

Sheets("Revinate").Activate
Range("a8").Select

Do While ActiveCell.Value <> ""

DoEvents

tf = WorksheetFunction.IsText((WorksheetFunction.VLookup(ActiveCell.Value, Range("rev_map"), 2, "false")))
    
    If tf = True Then
    
        arr_string = WorksheetFunction.VLookup(ActiveCell.Value, Range("rev_map"), 2, "false")
        ActiveCell.Offset(-1, 0).Value = arr_string
    
    Else
    
        indexcol = WorksheetFunction.VLookup(ActiveCell.Value, Range("rev_map"), 2, "false")
        If indexcol <> 0 Then
            ActiveCell.Offset(-1, 0).Value = indexcol
        End If
    
    End If
    
    ActiveCell.Offset(0, 1).Select

Loop

Range("a8").Select

Range("c1").Value = WorksheetFunction.CountIf(Range("b:b"), "Rev*")
import_recs = Range("c1").Value

For x = 1 To import_recs
    
    stime = Now
    
    Application.StatusBar = "Working on Record " & x & " of " & import_recs
    
    Stop
    
    ActiveCell.Offset(1, 0).Select
    
    '------------evaluate record
    rec_id = ActiveCell.Offset(0, WorksheetFunction.Match("Survey ID", Range("8:8"), 0) - 1).Value
    rec_tab = WorksheetFunction.VLookup(Left(ActiveCell.Value, 7) & "*", Range("prop_table"), 2, 0)
    h_array_vals = ActiveCell.Offset(0, WorksheetFunction.Match("heardaboutus", Range("8:8"), 0) - 1).Value
    s_array_vals = ActiveCell.Offset(0, WorksheetFunction.Match("socialmedianetworks", Range("8:8"), 0) - 1).Value
    
    
    '-----------test if record already exists
    rec_check = ""
    On Error Resume Next
    rec_check = WorksheetFunction.VLookup(rec_id, Range(rec_tab & "!a:a"), 1, 0)
        
    If rec_check = "" Then
        
        '------------add record
        rec_row = ActiveCell.Row
        
        Sheets(rec_tab).Select
        Range("a" & WorksheetFunction.CountA(Range("a:a")) + 1).Select
        add_rec_row = ActiveCell.Row
        
        For c = 0 To 78
        
            DoEvents
            
            ActiveCell.Offset(0, c).Value = WorksheetFunction.HLookup(c + 1, Range("Revinate!" & "a7:bv" & import_recs + 7), x + 2, 0)
            
            If c < 77 Then
            
                If ActiveCell.Offset(0, c).Value = 5 Then ActiveCell.Offset(0, c).Value = "Great"
                If ActiveCell.Offset(0, c).Value = 4 Then ActiveCell.Offset(0, c).Value = "Good"
                If ActiveCell.Offset(0, c).Value = 3 Then ActiveCell.Offset(0, c).Value = "OK"
                If ActiveCell.Offset(0, c).Value = 2 Then ActiveCell.Offset(0, c).Value = "Poor"
                If ActiveCell.Offset(0, c).Value = 1 Then ActiveCell.Offset(0, c).Value = "Bad"
            
            End If
        
        Next c
        
        '------------add heard_array values
                h_rec_count = WorksheetFunction.CountA(Range("heard_array")) / 2
        
        For y = 1 To h_rec_count
        
            teststr = WorksheetFunction.Index(Range("heard_array"), y, 1)
            pos = InStr(h_array_vals, teststr)
            
            If pos > 0 Then
                ActiveCell.Offset(0, WorksheetFunction.Index(Range("heard_array"), y, 2) - 1).Value = teststr
            End If
        
        Next y
        
        '------------add social_array values
                s_rec_count = WorksheetFunction.CountA(Range("social_array")) / 2
        
        For y = 1 To s_rec_count
        
            teststr = WorksheetFunction.Index(Range("social_array"), y, 1)
            pos = InStr(s_array_vals, teststr)
            
            If pos > 0 Then
                
                If teststr = "Not Applicable" Then teststr = "None"
                
                ActiveCell.Offset(0, WorksheetFunction.Index(Range("social_array"), y, 2) - 1).Value = teststr
            
            End If
        
        Next y
        
        '------------update statusbar stats
                looptime = Now - stime
        ltimestring = Format(looptime, "hh:mm:ss")
        
        donepct = x / import_recs
        donestr = Format(donepct, "##0.0%")
        Application.StatusBar = "Progress " & donestr & " / " & ltimestring
               
    End If

Sheets("Revinate").Activate

Next x

Application.StatusBar = False
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

[davesexcel]

Hard to say without seeing a sample of the workbook, there are a lot of loops being looped.

[mehmetcik]

1. Reduce the number of times VBA reads from or writes to excel.

2. Reduce the number of actions in a loop

eg:

            If c < 77 Then
            
                If ActiveCell.Offset(0, c).Value = 5 Then ActiveCell.Offset(0, c).Value = "Great"
                If ActiveCell.Offset(0, c).Value = 4 Then ActiveCell.Offset(0, c).Value = "Good"
                If ActiveCell.Offset(0, c).Value = 3 Then ActiveCell.Offset(0, c).Value = "OK"
                If ActiveCell.Offset(0, c).Value = 2 Then ActiveCell.Offset(0, c).Value = "Poor"
                If ActiveCell.Offset(0, c).Value = 1 Then ActiveCell.Offset(0, c).Value = "Bad"
            
            End If

In this scenario If your cell contains 1, you go through 5 if statements to return "Bad"

Try This
Enter this line outside your loop

AStatus =   Array("", "Bad", "Poor", "OK","Good", "Great")

Inside your loop enter

ActiveCell.Offset(0, c).Value = AStatus(ActiveCell.Offset(0, c).Value)

3. Use Excel to do what excel does best and VBA to do what it does best.

In your code you do something like this twice:-

        For y = 1 To h_rec_count
        
            teststr = WorksheetFunction.Index(Range("heard_array"), y, 1)
            pos = InStr(h_array_vals, teststr)
            
            If pos > 0 Then
                ActiveCell.Offset(0, WorksheetFunction.Index(Range("heard_array"), y, 2) - 1).Value = teststr
            End If
        
        Next y

If h_rec_count = 1000

Then you are reading 1000 excel cells into VBA one at a time

Looking for some text in each cell

If you find the text you are modifying a cell in excel.

It is a lot faster to use a helper column.

a. Insert a formula in an empty column to do the hard work.
b. Copy Paste your Values from your helper column into your Ammended Column
c. Clear your Helper column.

So three lines of code and no loop as opposed to your 1000 loops and six lines of code.

[xlnitwit]

Hi,

You should definitely turn Screenupdating off at the start of the code. Also avoid selecting things. And using Worksheetfunction.Index here is unnecessary

teststr = WorksheetFunction.Index(Range("social_array"), y, 1)

when you can just use

teststr = Range("social_array").Cells(y, 1)

[Norie]

What's the purpose of this section of the code?

Sheets("Revinate").Activate
Range("a8").Select

Do While ActiveCell.Value <> ""

DoEvents

tf = WorksheetFunction.IsText((WorksheetFunction.VLookup(ActiveCell.Value, Range("rev_map"), 2, "false")))
    
    If tf = True Then
    
        arr_string = WorksheetFunction.VLookup(ActiveCell.Value, Range("rev_map"), 2, "false")
        ActiveCell.Offset(-1, 0).Value = arr_string
    
    Else
    
        indexcol = WorksheetFunction.VLookup(ActiveCell.Value, Range("rev_map"), 2, "false")
        If indexcol <> 0 Then
            ActiveCell.Offset(-1, 0).Value = indexcol
        End If
    
    End If
    
    ActiveCell.Offset(0, 1).Select

Loop