Using a Variable array in place of a Vlookup to return values to VBA code

M

miless2111s

Active Member
Joined
Feb 10, 2016
Messages
279
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a set of sheets which contain data which I pull into my VBA code with vlookups. The input data is collected into a table of data 10 columns wide, the key field is always an integer between 1 and 3000 but depending on the data entered by the users I might have 5 entries or 3000. The code loops through all integers 1 to 3000 an inspects the data table, if the integer isn't found it returns a default set of values but if the integer is found the values in the table are used by the code and a range of values are generated.

Is a Vlookup an efficient method? I read somewhere that it might not be and if not should I be using a Variable Array? I have worked out how I can read the input data into an 2D array however I am unsure how I
1) Read down the 1st column of the 2d array to see if the integer value is there (if not return default values)
2) Locate the right "row" in the array and pull out each individual data item into various calculations

I also wonder if outputting an array might be more efficient that my current method which writes out each result cell by cell (the output from the entire code is 2,500 rows of 31 columns of data which couldn't be output in one array but maybe 2,500 array writes would be faster than 77K individual write operations?

Many thanks in advance

Miles
 
Sort by date Sort by votes
i will have time to study it after work today...
 
Upvote 0

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Diddi
I've had a go at various options using the new, more complex model, and measured the time differences. The options I tried were:
  1. Original: Using Vlookups to gather data from the sheets and output one cell at a time
  2. Using Vlookups to gather the data and an array to output the results one row at a time
  3. Using Vlookups to gather the data and an array to output all the data at once
  4. Using Vlookups in Arrays and outputting the data all at once
  5. Not using Vlookups at all but using arrays and a custom function to locate the data in the arrays, again outputting all the data in one array
My results, expressed as a percentage of the original speed were:
  1. 100%
  2. 56%
  3. 43%
  4. 60%
  5. 39%
I have saved the test sheet to the DropBox location and if you've got time I would love it if you could suggest improvements as I am stumbling around finding my way :)

I have copied the code out for 2 and 5 for ease...

Thanks

Miles
Using Vlookups and outputting all at once (2):
VBA Code: 
Sub Calcs()
Dim Input2 As Range
Dim Input_Data As Range
Dim Colours As Range
Dim Output As Range
Dim Count_Ref As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim OutputRow As Integer
Dim Colour As String
Dim Foreground As String
Dim Text As String
Dim Val_1 As String
Dim Val_2 As String
Dim Val_3 As String
Dim Ref As String
Dim Name As String

For r = 2 To 1000
t = Timer

Application.ScreenUpdating = False
On Error GoTo ErrHandle:
Error_msg = ""

Set wb = ActiveWorkbook
Set ws = wb.Sheets("output")

'set ranges
Set Input2 = Worksheets("Input 2").Range("Input2")
Set Input_Data = Worksheets("data").Range("Input_data")
Set Colours = Worksheets("Colours").Range("Colours")
Set Output = Worksheets("output").Range("a1:G31")

OutputRow = 2

For Count_Ref = 1 To 5
    Ref = Count_Ref
    Error_msg = "Doing calcs for " & Count_Ref
    'check if Ref is in data set AND has a y against it in the Input 2 sheet, if not return default values
    If IsError(Application.VLookup(Count_Ref, Input_Data, 1, False)) Or Not (Application.VLookup(Count_Ref, Input2, 2, False) = "y") Then
        'Default values
        Name = "blank 1-5"
        Foreground = "RGB(255,255,255)"
        Text = "RGB(255,0,0)"
        Val_1 = "10 mm"
        Val_2 = "5 mm"
        Val_3 = 1
        
    Else
        'Do Calcs for 1-5
        Name = Application.VLookup(Count_Ref, Input_Data, 2, False)
        Colour = Application.VLookup(Count_Ref, Input_Data, 3, False)
        If IsError(Application.VLookup(Colour, Colours, 1, False)) Then Colour = "unknown" Else Colour = Colour
        Foreground = Application.VLookup(Colour, Colours, 2, False)
        Text = Application.VLookup(Colour, Colours, 3, False)
        Val_1 = Application.VLookup(Count_Ref, Input_Data, 4, False) * 2 & " mm"
        Val_2 = Application.VLookup(Count_Ref, Input_Data, 5, False) * 1 & " mm"
        Val_3 = Application.VLookup(Count_Ref, Input2, 3, False)
    End If
    
    'Enter Values in output
    PrintOutput ws, "a", OutputRow, Ref
    PrintOutput ws, "b", OutputRow, Name
    PrintOutput ws, "c", OutputRow, Foreground
    PrintOutput ws, "d", OutputRow, Text
    PrintOutput ws, "e", OutputRow, Val_1
    PrintOutput ws, "f", OutputRow, Val_2
    PrintOutput ws, "g", OutputRow, Val_3
    
    OutputRow = OutputRow + 1

Next Count_Ref

For Count_Ref = 6 To 10
    Ref = Count_Ref
    Error_msg = "Doing calcs for " & Count_Ref
    'check if Ref is in data set AND has a y against it in the Input 2 sheet, if not return default values
    If IsError(Application.VLookup(Count_Ref, Input_Data, 1, False)) Or Application.VLookup(Count_Ref, Input2, 1, False) = "" Then
        'Default values
        Name = "blank 6-10"
        Foreground = "RGB(255,255,255)"
        Text = "RGB(255,0,0)"
        Val_1 = "10 mm"
        Val_2 = "5 mm"
        Val_3 = 1
    Else
        'Do Calcs for 6-10
        Name = Application.VLookup(Count_Ref, Input_Data, 2, False)
        Colour = Application.VLookup(Count_Ref, Input_Data, 3, False)
        If IsError(Application.VLookup(Colour, Colours, 1, False)) Then Colour = "unknown" Else Colour = Colour
        Foreground = Application.VLookup(Colour, Colours, 2, False)
        Text = Application.VLookup(Colour, Colours, 3, False)
        Val_1 = Application.VLookup(Count_Ref, Input_Data, 4, False) * 1.5 & " mm"
        Val_2 = Application.VLookup(Count_Ref, Input_Data, 5, False) * 1 & " mm"
        Val_3 = Application.VLookup(Count_Ref, Input2, 3, False)
    End If
    
    'Enter Values in output
    PrintOutput ws, "a", OutputRow, Ref
    PrintOutput ws, "b", OutputRow, Name
    PrintOutput ws, "c", OutputRow, Foreground
    PrintOutput ws, "d", OutputRow, Text
    PrintOutput ws, "e", OutputRow, Val_1
    PrintOutput ws, "f", OutputRow, Val_2
    PrintOutput ws, "g", OutputRow, Val_3
    
    OutputRow = OutputRow + 1
    
Next Count_Ref

For Count_Ref = 10 To 20
    Ref = Count_Ref
    Error_msg = "Doing calcs for " & Count_Ref
    'check if Ref is in data set AND has a y against it in the Input 2 sheet, if not return default values
    If IsError(Application.VLookup(Count_Ref, Input_Data, 1, False)) Or Application.VLookup(Count_Ref, Input2, 1, False) = "" Then
        'Default values
        Name = "blank 10-20"
        Foreground = "RGB(255,255,255)"
        Text = "RGB(255,0,0)"
        Val_1 = "10 mm"
        Val_2 = "5 mm"
        Val_3 = 1
    Else
        'Do Calcs for 10-20
        Name = Application.VLookup(Count_Ref, Input_Data, 2, False)
        Colour = Application.VLookup(Count_Ref, Input_Data, 3, False)
        If IsError(Application.VLookup(Colour, Colours, 1, False)) Then Colour = "unknown" Else Colour = Colour
        Foreground = Application.VLookup(Colour, Colours, 2, False)
        Text = Application.VLookup(Colour, Colours, 3, False)
        Val_1 = Application.VLookup(Count_Ref, Input_Data, 4, False) * 3 & " mm"
        Val_2 = Application.VLookup(Count_Ref, Input_Data, 5, False) + 10 & " mm"
        Val_3 = Application.VLookup(Count_Ref, Input2, 3, False)
        Ref = Count_Ref
    End If
    
    'Enter Values in output
    PrintOutput ws, "a", OutputRow, Ref
    PrintOutput ws, "b", OutputRow, Name
    PrintOutput ws, "c", OutputRow, Foreground
    PrintOutput ws, "d", OutputRow, Text
    PrintOutput ws, "e", OutputRow, Val_1
    PrintOutput ws, "f", OutputRow, Val_2
    PrintOutput ws, "g", OutputRow, Val_3
    
    OutputRow = OutputRow + 1
    
Next Count_Ref

For Count_Ref = 21 To 30
    Ref = Count_Ref
    Error_msg = "Doing calcs for " & Count_Ref
    'check if Ref is in data set AND has a y against it in the Input 2 sheet, if not return default values
    If IsError(Application.VLookup(Count_Ref, Input_Data, 1, False)) Or Application.VLookup(Count_Ref, Input2, 1, False) = "" Then
        'Default values
        Name = "blank 21-50"
        Foreground = "RGB(255,255,255)"
        Text = "RGB(255,0,0)"
        Val_1 = "10 mm"
        Val_2 = "5 mm"
        Val_3 = 1
    Else
        'Do Calcs for 21-30
        Name = Application.VLookup(Count_Ref, Input_Data, 2, False)
        Colour = Application.VLookup(Count_Ref, Input_Data, 3, False)
        If IsError(Application.VLookup(Colour, Colours, 1, False)) Then Colour = "unknown" Else Colour = Colour
        Foreground = Application.VLookup(Colour, Colours, 2, False)
        Text = Application.VLookup(Colour, Colours, 3, False)
        Val_1 = Application.VLookup(Count_Ref, Input_Data, 4, False) - 1 & " mm"
        Val_2 = Application.VLookup(Count_Ref, Input_Data, 5, False) / 2 & " mm"
        Val_3 = Application.VLookup(Count_Ref, Input2, 3, False)
    End If
    
    'Enter Values in output
    PrintOutput ws, "a", OutputRow, Ref
    PrintOutput ws, "b", OutputRow, Name
    PrintOutput ws, "c", OutputRow, Foreground
    PrintOutput ws, "d", OutputRow, Text
    PrintOutput ws, "e", OutputRow, Val_1
    PrintOutput ws, "f", OutputRow, Val_2
    PrintOutput ws, "g", OutputRow, Val_3
    
    OutputRow = OutputRow + 1
    
Next Count_Ref

    Application.ScreenUpdating = True
t = Timer - t
Worksheets("output").Range("j" & r) = t
Next r

Exit Sub
ErrHandle:
    If Err.Number > 0 Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
   ' Worksheets("Calcs for standard settings").Range("E1").Value = "error"
    MsgBox "The update has failed due to:" & vbNewLine & Error_msg & vbNewLine & "(error " & Err.Number & " - " & Err.Description & ")" & vbNewLine & "Please check for errors in code or data set", vbOKOnly + vbCritical, "Test Programm"
End Sub
Option Private Module
Sub PrintOutput(ws As Worksheet, sCol As String, OutputRow As Integer, sValue As String)
   ws.Range(sCol & OutputRow).Value = sValue
   'If Not (ws.Range(sCol & OutputRow).Value = sValue) Then ws.Range(sCol & OutputRow).Value = sValue
End Sub

Option Private Module
Sub PrintOutput(ws As Worksheet, sCol As String, OutputRow As Integer, sValue As String)
   ws.Range(sCol & OutputRow).Value = sValue
   'If Not (ws.Range(sCol & OutputRow).Value = sValue) Then ws.Range(sCol & OutputRow).Value = sValue
End Sub
Using only arrays (5):
Code: 
Option Base 1
Sub Arrays_only_TwoD_output()

'need to work this one out


Dim Input2 As Range
Dim Input_Data As Range
Dim Colours As Range
Dim Output As Range
Dim Count_Ref As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim OutputRow As Integer
Dim Colour As String
Dim Foreground As String
Dim Text As String
Dim Val_1 As String
Dim Val_2 As String
Dim Val_3 As String
Dim Ref As String
Dim Name As String
'Dim output_arr As Variant
Dim output_arr(30, 7)

For r = 2 To 1000
Erase output_arr
t = Timer

Application.ScreenUpdating = False
On Error GoTo ErrHandle:
Error_msg = ""

Set wb = ActiveWorkbook
Set ws = wb.Sheets("output")
last_input_row = Worksheets("data").Range("a1").End(xlDown).Row

'set ranges
Set Input2 = Worksheets("Input 2").Range("Input2")
Set Input_Data = Worksheets("data").Range("Input_data")
Set Colours = Worksheets("Colours").Range("Colours")
Set Output = Worksheets("output").Range("a1:G31")
Colour_var = Worksheets("Colours").Range("a1:c5").Value
input2_var = Worksheets("Input 2").Range("Input2").Value
input_data_var = Worksheets("data").Range("A1:E" & last_input_row).Value

OutputRow = 2

For Count_Ref = 1 To 5
    Ref = ""
    Name = ""
    Foreground = ""
    Text = ""
    Val_1 = ""
    Val_2 = ""
    Val_3 = ""


    Ref = Count_Ref
    
'use a function similar to that in https://stackoverflow.com/questions/38267950/check-if-a-value-is-in-an-array-or-not-with-excel-vba/52192798#52192798
'to find the index position in the Input_data_arr to then read off data for the specific Ref

    
    Error_msg = "Doing calcs for " & Count_Ref
    'check if Ref is in data set AND has a y against it in the Input 2 sheet, if not return default values
    result = Is_Ref_In_Array(Ref, input_data_var)
    If result = -1 Then
        'default values
        Name = "blank 1-5"
        Foreground = "RGB(255,255,255)"
        Text = "RGB(255,0,0)"
        Val_1 = "10 mm"
        Val_2 = "5 mm"
        Val_3 = 1
        
    Else
        'check for presence of "y" in Input_data2_var at calculated Ref position
        If input2_var(Ref + 1, 2) <> "y" Then
            Name = "blank 1-5"
            Foreground = "RGB(255,255,255)"
            Text = "RGB(255,0,0)"
            Val_1 = "10 mm"
            Val_2 = "5 mm"
            Val_3 = 1
        Else
            'do calcs for ref using result as the key for input_data_var
            Name = input_data_var(result, 2)
            Val_1 = input_data_var(result, 4) * 2 & " mm"
            Val_2 = input_data_var(result, 5) * 1 & " mm"
            Val_3 = input2_var(Ref + 1, 3)
            'find colour
            Colour = input_data_var(result, 3)
            col_result = Is_Ref_In_Array(Colour, Colour_var)
            If col_result = -1 Then col_result = Is_Ref_In_Array("Unknown", Colour_var) Else col_result = col_result
            Foreground = Colour_var(col_result, 2)
            Text = Colour_var(col_result, 3)
        End If
    End If
    
    'save results to output array
    ColHeadings = Array(Ref, Name, Foreground, Text, Val_1, Val_2, Val_3)
    For c = 1 To 7
        col = ColHeadings(c)
        output_arr(OutputRow - 1, c) = col
    Next c
    
    OutputRow = OutputRow + 1

Next Count_Ref

For Count_Ref = 6 To 10
    Ref = ""
    Name = ""
    Foreground = ""
    Text = ""
    Val_1 = ""
    Val_2 = ""
    Val_3 = ""
    
    Ref = Count_Ref
    Error_msg = "Doing calcs for " & Count_Ref
    
    'check if Ref is in data set AND has a y against it in the Input 2 sheet, if not return default values
    result = Is_Ref_In_Array(Ref, input_data_var)
    If result = -1 Then
        'default values
        Name = "blank 1-5"
        Foreground = "RGB(255,255,255)"
        Text = "RGB(255,0,0)"
        Val_1 = "10 mm"
        Val_2 = "5 mm"
        Val_3 = 1
        
    Else
        'check for presence of "y" in Input_data2_var at calculated Ref position
        If input2_var(Ref + 1, 2) <> "y" Then
            Name = "blank 1-5"
            Foreground = "RGB(255,255,255)"
            Text = "RGB(255,0,0)"
            Val_1 = "10 mm"
            Val_2 = "5 mm"
            Val_3 = 1
        Else
            'do calcs for ref using result as the key for input_data_var
            Name = input_data_var(result, 2)
            Val_1 = input_data_var(result, 4) * 1.5 & " mm"
            Val_2 = input_data_var(result, 5) * 1 & " mm"
            Val_3 = input2_var(Ref + 1, 3)
            'find colour
            Colour = input_data_var(result, 3)
            col_result = Is_Ref_In_Array(Colour, Colour_var)
            If col_result = -1 Then col_result = Is_Ref_In_Array("Unknown", Colour_var) Else col_result = col_result
            Foreground = Colour_var(col_result, 2)
            Text = Colour_var(col_result, 3)
        End If
    End If
    
    'save results to output array
   ColHeadings = Array(Ref, Name, Foreground, Text, Val_1, Val_2, Val_3)
   For c = 1 To 7
        col = ColHeadings(c)
        output_arr(OutputRow - 1, c) = col
    Next c

    OutputRow = OutputRow + 1
    
Next Count_Ref

For Count_Ref = 11 To 20
    Ref = ""
    Name = ""
    Foreground = ""
    Text = ""
    Val_1 = ""
    Val_2 = ""
    Val_3 = ""
    
    Ref = Count_Ref
    Error_msg = "Doing calcs for " & Count_Ref
    
        'check if Ref is in data set AND has a y against it in the Input 2 sheet, if not return default values
    result = Is_Ref_In_Array(Ref, input_data_var)
    If result = -1 Then
        'default values
        Name = "blank 1-5"
        Foreground = "RGB(255,255,255)"
        Text = "RGB(255,0,0)"
        Val_1 = "10 mm"
        Val_2 = "5 mm"
        Val_3 = 1
        
    Else
        'check for presence of "y" in Input_data2_var at calculated Ref position
        If input2_var(Ref + 1, 2) <> "y" Then
            Name = "blank 1-5"
            Foreground = "RGB(255,255,255)"
            Text = "RGB(255,0,0)"
            Val_1 = "10 mm"
            Val_2 = "5 mm"
            Val_3 = 1
        Else
            'do calcs for ref using result as the key for input_data_var
            Name = input_data_var(result, 2)
            Val_1 = input_data_var(result, 4) * 3 & " mm"
            Val_2 = input_data_var(result, 5) + 10 & " mm"
            Val_3 = input2_var(Ref + 1, 3)
            'find colour
            Colour = input_data_var(result, 3)
            col_result = Is_Ref_In_Array(Colour, Colour_var)
            If col_result = -1 Then col_result = Is_Ref_In_Array("Unknown", Colour_var) Else col_result = col_result
            Foreground = Colour_var(col_result, 2)
            Text = Colour_var(col_result, 3)
        End If
    End If
 
    'Enter Values in output
    ColHeadings = Array(Ref, Name, Foreground, Text, Val_1, Val_2, Val_3)
    For c = 1 To 7
        col = ColHeadings(c)
        output_arr(OutputRow - 1, c) = col
    Next c
    
    OutputRow = OutputRow + 1
    
Next Count_Ref

For Count_Ref = 21 To 30
    Ref = ""
    Name = ""
    Foreground = ""
    Text = ""
    Val_1 = ""
    Val_2 = ""
    Val_3 = ""
    
    Ref = Count_Ref
    Error_msg = "Doing calcs for " & Count_Ref
    
    'check if Ref is in data set AND has a y against it in the Input 2 sheet, if not return default values
    result = Is_Ref_In_Array(Ref, input_data_var)
    If result = -1 Then
        'default values
        Name = "blank 1-5"
        Foreground = "RGB(255,255,255)"
        Text = "RGB(255,0,0)"
        Val_1 = "10 mm"
        Val_2 = "5 mm"
        Val_3 = 1
        
    Else
        'check for presence of "y" in Input_data2_var at calculated Ref position
        If input2_var(Ref + 1, 2) <> "y" Then
            Name = "blank 1-5"
            Foreground = "RGB(255,255,255)"
            Text = "RGB(255,0,0)"
            Val_1 = "10 mm"
            Val_2 = "5 mm"
            Val_3 = 1
        Else
            'do calcs for ref using result as the key for input_data_var
            Name = input_data_var(result, 2)
            Val_1 = input_data_var(result, 4) - 1 & " mm"
            Val_2 = input_data_var(result, 5) / 2 & " mm"
            Val_3 = input2_var(Ref + 1, 3)
            'find colour
            Colour = input_data_var(result, 3)
            col_result = Is_Ref_In_Array(Colour, Colour_var)
            If col_result = -1 Then col_result = Is_Ref_In_Array("Unknown", Colour_var) Else col_result = col_result
            Foreground = Colour_var(col_result, 2)
            Text = Colour_var(col_result, 3)
        End If
    End If
    
  
    'Enter Values in output
    ColHeadings = Array(Ref, Name, Foreground, Text, Val_1, Val_2, Val_3)
    For c = 1 To 7
        col = ColHeadings(c)
        output_arr(OutputRow - 1, c) = col
    Next c
    
 
    OutputRow = OutputRow + 1
    
Next Count_Ref

Sheets("Output").Range("A2:G" & OutputRow - 1) = output_arr

Application.ScreenUpdating = True
t = Timer - t
Worksheets("output").Range("j" & r) = t
Next r

Exit Sub
ErrHandle:
    If Err.Number > 0 Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
    MsgBox "The update has failed due to:" & vbNewLine & Error_msg & vbNewLine & "(error " & Err.Number & " - " & Err.Description & ")" & vbNewLine & "Please check for errors in code or data set", vbOKOnly + vbCritical, "Test Programm"
End Sub



'-1 if not found
'https://stackoverflow.com/a/56327647/1915920
Public Function Is_Ref_In_Array(item As String, arr As Variant) As Long

    Is_Ref_In_Array = -1

    Dim i As Long
    
    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, 1) = item Then
            Is_Ref_In_Array = i
            Exit Function
        End If
    Next i

End Function
 
Upvote 0
Solution
looks very well thought out. i will look today. glad you have found the process useful in improving the efficiency of the project
 
Upvote 0
Heres my version to time trial on your PC

VBA Code: 
Option Base 1

Sub Arrays_Version2()
    Dim RefIndex(30, 7), Last_input_row As Long
    Dim ColIdx(30), ColHeadings()
    
    For r = 2 To 1000
        Erase RefIndex
        t = Timer
        
        Application.ScreenUpdating = False

        Last_input_row = Worksheets("Data").Range("a1").End(xlDown).Row
        Colours_var = Worksheets("Colours").Range("a2:c5").Value
        input2_var = Worksheets("Input 2").Range("a2:c31").Value
        data_var = Worksheets("Data").Range("A1:E" & Last_input_row).Value
        
        For Row = 2 To Last_input_row
            'define ColourIndex
            For col = 1 To 3
                If data_var(Row, 3) = Colours_var(col, 1) Then
                    ColIdx(Row) = col
                    Exit For
                End If
            Next col
            If ColIdx(Row) = 0 Then ColIdx(Row) = 4
            'define rules for variables 1,2,3
            Select Case data_var(Row, 1)
                Case 1 To 5
                    data_var(Row, 4) = data_var(Row, 4) * 2
                Case 6 To 10
                    data_var(Row, 4) = data_var(Row, 4) * 1.5
                Case 11 To 20
                    data_var(Row, 4) = data_var(Row, 4) * 3
                    data_var(Row, 5) = data_var(Row, 5) + 10
                Case 21 To 30
                    data_var(Row, 4) = data_var(Row, 4) - 1
                    data_var(Row, 5) = data_var(Row, 5) / 2
            End Select
        Next Row
        
        defaults = Array("", "blank 1-5", "RGB(255,255,255)", "RGB(255,0,0)", "10 mm", "5 mm", 1)
        ' Populate RefIndex
        For Row = 1 To 30
            RefIndex(Row, 1) = Row
            For col = 2 To 7
                RefIndex(Row, col) = defaults(col)
            Next col
        Next Row
              
        For Row = 2 To Last_input_row
            If input2_var(data_var(Row, 1), 2) = "y" Then
                RefIndex(data_var(Row, 1), 2) = data_var(Row, 2)
                RefIndex(data_var(Row, 1), 3) = Colours_var(ColIdx(Row), 2)
                RefIndex(data_var(Row, 1), 4) = Colours_var(ColIdx(Row), 3)
                RefIndex(data_var(Row, 1), 5) = data_var(Row, 4) & " mm"
                RefIndex(data_var(Row, 1), 6) = data_var(Row, 5) & " mm"
                RefIndex(data_var(Row, 1), 7) = input2_var(data_var(Row, 1), 3)
            End If
        Next Row
        
        'dump array data
        ColHeadings = Array("Ref", "Name", "Foreground", "Text", "Val_1", "Val_2", "Val_3")

        With Sheets("Output")
            .Range("A1:G1").Value = ColHeadings
            .Range("A2:G" & UBound(RefIndex) + 1) = RefIndex
            Application.ScreenUpdating = True
            .Cells(r, 10) = Timer - t
        End With
    Next r
End Sub
 
Last edited:
Upvote 0
diddi said:
Heres my version to time trial on your PC

VBA Code: 
Option Base 1

Sub Arrays_Version2()
    Dim RefIndex(30, 7), Last_input_row As Long
    Dim ColIdx(30), ColHeadings()
   
    For r = 2 To 1000
        Erase RefIndex
        t = Timer
       
        Application.ScreenUpdating = False

        Last_input_row = Worksheets("Data").Range("a1").End(xlDown).Row
        Colours_var = Worksheets("Colours").Range("a2:c5").Value
        input2_var = Worksheets("Input 2").Range("a2:c31").Value
        data_var = Worksheets("Data").Range("A1:E" & Last_input_row).Value
       
        For Row = 2 To Last_input_row
            'define ColourIndex
            For col = 1 To 3
                If data_var(Row, 3) = Colours_var(col, 1) Then
                    ColIdx(Row) = col
                    Exit For
                End If
            Next col
            If ColIdx(Row) = 0 Then ColIdx(Row) = 4
            'define rules for variables 1,2,3
            Select Case data_var(Row, 1)
                Case 1 To 5
                    data_var(Row, 4) = data_var(Row, 4) * 2
                Case 6 To 10
                    data_var(Row, 4) = data_var(Row, 4) * 1.5
                Case 11 To 20
                    data_var(Row, 4) = data_var(Row, 4) * 3
                    data_var(Row, 5) = data_var(Row, 5) + 10
                Case 21 To 30
                    data_var(Row, 4) = data_var(Row, 4) - 1
                    data_var(Row, 5) = data_var(Row, 5) / 2
            End Select
        Next Row
       
        defaults = Array("", "blank 1-5", "RGB(255,255,255)", "RGB(255,0,0)", "10 mm", "5 mm", 1)
        ' Populate RefIndex
        For Row = 1 To 30
            RefIndex(Row, 1) = Row
            For col = 2 To 7
                RefIndex(Row, col) = defaults(col)
            Next col
        Next Row
             
        For Row = 2 To Last_input_row
            If input2_var(data_var(Row, 1), 2) = "y" Then
                RefIndex(data_var(Row, 1), 2) = data_var(Row, 2)
                RefIndex(data_var(Row, 1), 3) = Colours_var(ColIdx(Row), 2)
                RefIndex(data_var(Row, 1), 4) = Colours_var(ColIdx(Row), 3)
                RefIndex(data_var(Row, 1), 5) = data_var(Row, 4) & " mm"
                RefIndex(data_var(Row, 1), 6) = data_var(Row, 5) & " mm"
                RefIndex(data_var(Row, 1), 7) = input2_var(data_var(Row, 1), 3)
            End If
        Next Row
       
        'dump array data
        ColHeadings = Array("Ref", "Name", "Foreground", "Text", "Val_1", "Val_2", "Val_3")

        With Sheets("Output")
            .Range("A1:G1").Value = ColHeadings
            .Range("A2:G" & UBound(RefIndex) + 1) = RefIndex
            Application.ScreenUpdating = True
            .Cells(r, 10) = Timer - t
        End With
    Next r
End Sub
Click to expand...
Diddi
That's a very interesting structure and certainly something for me to think about for the actual code. The model uses the Var_1 and Var_2 calculations as a short hand for 10-100 calculations that happen for each different data type but the use of Case maybe very useful; I will have to think about it.
I love the idea of populating all values with the default and then over-writing with the actual data as needed.
Your code ran 1% faster than mine which is much less of a difference than I was expecting given how clean it looks when written down, but I wonder if your advantage would grow when used in the more complex real world situation.
Thank you for your help
Miles
 
Upvote 0
what are the actual sizes of the various data sets? if they are huge i would do it differently again
 
Upvote 0
diddi said:
what are the actual sizes of the various data sets? if they are huge i would do it differently again
Click to expand...
The actual output data set is a table which is 35 columns wide and 2,539 rows. Within this not all cells are populated (8306 cells are blank) so we have a total of 80,524 data points.
At the moment with the current method the code checks to see if the value in each cell has to change, if it doesn't then that cell isn't overwritten. I can't quantify the exact amount of change each refresh as it varies a great deal however the update time is typically 20-40 seconds.



​
 
Upvote 0
so what are the sizes of Colours, Data and Input, and will it be the case that any row in Data is marked Yes in Input
 
Upvote 0
The colour array is 100 (but can expand) x12
Data can be up to any length but is normally 10-300 or so x 12
Input2 is 450-550 x 10
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
VBA can't assign function return value to array
Replies
9
Views
460
ronga2001
R
J
  • Solved
Using variable in Worksheets.Shapes.Range(Array("")).Select
Replies
4
Views
658
jlc19
J
S
  • Question Question
VBA - Filter a class array based on class function
Replies
1
Views
158
RoryA
RoryA
B
  • Solved
Search vlookup more than 1 column
2 3
Replies
23
Views
411
DanteAmor
DanteAmor
U
  • Solved
ADDING 2ND COLUMN TO ARRAY, THEN ONLY OUTPUTTING THE SECOND COLUMN
Replies
3
Views
267
StephenCrump
S

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top