My seemingly simply code is VERY slow RRS feed

  • Question

  • Hi there. I'm new to this forum, so please go easy on me if the information provided is is somewhat incomplete.

    I use Excel 2007

    In the sheet “results” I have a list of company deals. 
    For each Target company (the one which has been bought by the Acquirer) there is a unique “Target BvD ID number” which we can use to match data between the two sheets “results” (my main sheet) and “data to incorporate” (the sheet from where I wish to import pieces of data).
    In other words, I simply want the VBA code to take the 12 colums of data (for each unique “Target BvD ID number”) from the sheet called “Data to incorporate”, and put it where it belongs in the sheet called “results” (matched by the right Id number).

    The Problem: Now, the code actually does what its meant to, but it is really slow. After half an hour, it wasn't even half way through the task. How do i speed it up?

    If it is possible, i would like to attach the Excel file..

    The code:

    Sub Dataimport()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim Dataimport(4000, 13) As Variant

    'Data regarding the Target company is gathered
    For i = 1 To 4000
    For j = 1 To 13
    Dataimport(i, j) = Sheets("Data to incorporate").Cells(i + 2, j)
    Next j
    Next i

    'The imported data is matched with the data in the sheet "results"
    For j = 1 To 4000
    For i = 1 To 4000
    For h = 1 To 12
    If Sheets("Results").Cells(j + 3, 3) = Dataimport(i, 1) Then Sheets("Results").Cells(j + 3, h + 16) = Dataimport(i, h + 1)
    Next h
    Next i
    Next j

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    End Sub

    Thursday, March 14, 2013 5:06 PM

All replies

  • Try this - a lot less looping:

    Sub DataImport()
        Dim wshR As Worksheet
        Dim wshD As Worksheet
        Dim r As Long
        Dim m As Long
        Dim cel As Range
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Set wshR = Worksheets("Results")
        Set wshD = Worksheets("Data to incorporate")
        m = wshR.Cells(wshR.Rows.Count, 3).End(xlUp).Row
        For r = 4 To m
            Set cel = wshD.Range("A:A").Find(What:=wshR.Cells(r, 3).Value, LookAt:=xlWhole)
            If Not cel Is Nothing Then
                wshR.Cells(r, 17).Resize(1, 12).Value = cel.Offset(0, 1).Resize(1, 12).Value
            End If
        Next r
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End Sub

    Regards, Hans Vogelaar

    Thursday, March 14, 2013 8:03 PM