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