RetriveValueFromKey() is a function that I’ve written. It searches records for a specific set of keys. If the keys are matched then that record is copied to a specific location. The code for the function is written below. I would appreciate if you are using this code to give reference to my blog. You can download the full code here:

Jump To:

• Input Parameters
• Example 1
• Example 2
• Example 3

Option Explicit


'Searches a column of values to find the target string. If
'found the value in the value column is printed in the output
'location specified
'strKeys() : Values to search for
'wrksheet_Key : sheet to look for strKey and Values
'row_Key : row to start searching for key
'column_Key() : column you can find the keys in
'column_Value() : columns you can find the values in
'wrksheet_output : worksheet to print values
'row_output : row to start printing output in
'column_Output : column to start printing output in
'Return Value: The number of data printed in the output column
'arrColumnMap: An array, mapping the columns in the value worksheet
'to the columns they are supposed to go in the output
' worksheet. The first map value should be smallest
Public Function RetrieveValueFromKey(ByRef strKeys() As Variant, _
ByRef wrksheet_Key As Worksheet, ByVal row_Key As Integer, _
ByRef column_Keys() As Integer, ByRef column_Value() As Integer, _
ByRef wrksheet_Output As Worksheet, ByVal row_Output As Integer, _
ByRef arrColumnMap() As Integer) As Integer

Dim count_Key As Integer
Dim count_OutputRows As Integer
Dim count_OutputColumns As Integer
Dim i As Integer
Dim arrTemp() As Variant
Dim strRange As String
Dim strColumn As String
Dim flagMatch As Boolean
Dim j As Integer
Dim arrTempColumnToAdd() As Variant
Dim arrKeyRangeData() As Variant
Dim arrValueRangeData() As Variant
Dim arrOutputRangeData() As Variant

count_Key = Get_Count(row_Key, column_Keys(1), wrksheet_Key, True)
ReDim arrKeyRangeData(1 To count_Key, 1 To UBound(strKeys))
ReDim arrValueRangeData(1 To count_Key, 1 To UBound(column_Value))

If count_Key <> 0 Then
    strRange = "=" + wrksheet_Key.Name + "!"
    strColumn = Get_Alphabet(column_Keys(1))
    strRange = strRange + strColumn + Strings.Trim(Str(row_Key)) + ":" + _
    strColumn + Strings.Trim(Str(row_Key + count_Key - 1))
    arrTempColumnToAdd = Range(strRange).Value
   
    Call Add_Column(arrKeyRangeData, arrTempColumnToAdd, 1)
    For i = 2 To UBound(column_Keys)
        strColumn = Get_Alphabet(column_Keys(i))
        strRange = "=" + wrksheet_Key.Name + "!"

        strRange = strRange + strColumn + Strings.Trim(Str(row_Key)) + ":" _
        + strColumn + Strings.Trim(Str(row_Key + count_Key - 1))
        arrTempColumnToAdd = Range(strRange).Value
        Call Add_Column(arrKeyRangeData, arrTempColumnToAdd, i)
    Next i
   
    strRange = "=" + wrksheet_Key.Name + "!"
    strColumn = Get_Alphabet(column_Value(1))
    strRange = strRange + strColumn + Strings.Trim(Str(row_Key)) + ":" + _
    strColumn + Strings.Trim(Str(row_Key + count_Key - 1))
    arrTempColumnToAdd = Range(strRange).Value
   
    Call Add_Column(arrValueRangeData, arrTempColumnToAdd, 1)
    For i = 2 To UBound(column_Value)
   
        strColumn = Get_Alphabet(column_Value(i))
        strRange = "=" + wrksheet_Key.Name + "!"

        strRange = strRange + strColumn + Strings.Trim(Str(row_Key)) + ":" + _
        strColumn + Strings.Trim(Str(row_Key + count_Key - 1))
        arrTempColumnToAdd = Range(strRange).Value
        Call Add_Column(arrValueRangeData, arrTempColumnToAdd, i)
    Next i
End If

count_OutputRows = Get_Count(row_Output, arrColumnMap(1), wrksheet_Output, True)
count_OutputColumns = Get_Count(row_Output - 1, arrColumnMap(1), wrksheet_Output, False)
Call Clear_Column(row_Output, arrColumnMap(1), count_OutputRows, _
count_OutputColumns, wrksheet_Output)

If count_Key <> 0 Then
    ReDim arrOutputRangeData(1 To count_Key, 1 To UBound(column_Value))
    count_OutputRows = 1
End If

For i = 1 To count_Key
    flagMatch = True
    For j = 1 To UBound(column_Keys)
        If arrKeyRangeData(i, j) <> strKeys(j) Then
           flagMatch = False
        End If
    Next j
   
    If flagMatch = True Then
        For j = 1 To UBound(arrValueRangeData, 2)
           arrOutputRangeData(count_OutputRows, j) = arrValueRangeData(i, j)
           
        Next j
        count_OutputRows = count_OutputRows + 1
    End If
Next i
   
count_OutputRows = count_OutputRows - 1

arrOutputRangeData = Trim_Array(arrOutputRangeData, count_OutputRows)
'arrOutputColumn = TransposeArray(arrOutputColumn)

For i = 1 To UBound(arrOutputRangeData, 2)
    wrksheet_Output.Range(wrksheet_Output.Cells(row_Output, arrColumnMap(i)), _
        wrksheet_Output.Cells(row_Output + count_OutputRows - 1, _
        arrColumnMap(i))).Value2 = Get_ColumnFrom2DArray(arrOutputRangeData, i)
Next i

RetrieveValueFromKey = count_OutputRows
End Function

'Retrieves the amount of data at a spcefic column
'intRow: Row to start searching for data
'intColumn: Column to start searching for data
'wrksheet: worksheet to start searching for data
Private Function Get_Count(ByVal intRow As Integer, ByVal intColumn As Integer, ByRef wrkSheet As Worksheet, _
ByVal flagCountRows As Boolean) As Integer
Dim i As Integer
Dim flag As Boolean

i = 1
flag = True
While flag = True
    If flagCountRows = True Then
        If wrkSheet.Cells(i + intRow - 1, intColumn) <> "" Then
           i = i + 1
        Else
           flag = False
        End If
    Else
        If wrkSheet.Cells(intRow, intColumn + i - 1) <> "" Then
           i = i + 1
        Else
           flag = False
        End If
    End If
Wend

Get_Count = i - 1
End Function

'''
'Returns the alphabet associated with the column
'intNumber: The column number
'Return Value: Alphabet associated with the column number
Private Function Get_Alphabet(ByVal intNumber As Integer) As String
Get_Alphabet = Strings.Trim(Chr(intNumber + 64))
End Function

'Adds a column to an existing 2D array
'arrTotal: The array that the column will be added to
'arrColumn: The column that will be added to the 2D array
'intColumnIndex: The index which the column will be inserted
Private Sub Add_Column(ByRef arrTotal() As Variant, ByRef arrColumn() As Variant, ByVal intColumnIndex As Integer)
Dim i As Integer
For i = 1 To UBound(arrTotal)
    arrTotal(i, intColumnIndex) = arrColumn(i, 1)
Next i
End Sub

'Clears the content of a column starting from a specific row, with a set amount of date
'intRow: Row to start clearing data from
'intColumn: Column to start clearing data from
'countData: The amount of data to clear
'wkrsheet: Worksheet to clear the data from
Private  Sub Clear_Column(ByVal intRow As Integer, ByVal intColumn As Integer, ByVal countROws As Integer, _
ByVal countColumns As Integer, ByRef wrkSheet As Worksheet)
If countROws <> 0 Then
        wrkSheet.Range(wrkSheet.Cells(intRow, intColumn), wrkSheet.Cells(intRow + countROws - 1, intColumn + countColumns - 1)) = ""
End If
End Sub

'Copyes the values in the first part of the array to a new array
'arrInput: Array to take values from
'intCount: Amount of elements to take
'Return Value: The new array
Private Function Trim_Array(ByRef ArrInput() As Variant, ByVal intCount As Integer) As Variant()
Dim i As Integer
Dim arrTemp() As Variant
Dim j As Integer

ReDim arrTemp(1 To intCount, 1 To UBound(ArrInput, 2))
For i = 1 To intCount
    For j = 1 To UBound(ArrInput, 2)
           arrTemp(i, j) = ArrInput(i, j)
    Next j
Next i
Trim_Array = arrTemp
End Function
'''
'Returns a column from a 2d array
'arrInput: The array to retreive the column array from
'intColumn: The column index to retreive
'Return Value: The column needed
Private  Function Get_ColumnFrom2DArray(ByRef ArrInput() As Variant, ByVal intColumn As Integer) As Variant()
Dim i As Integer
Dim arrTemp() As Variant
ReDim arrTemp(1 To UBound(ArrInput), 1 To 1)
For i = 1 To UBound(ArrInput)
    arrTemp(i, 1) = ArrInput(i, intColumn)
Next i

Get_ColumnFrom2DArray = arrTemp
End Function


Input Parameters:

strKeys(): This is an array of string values. Each of these values is a key. The function checks the set of records for these keys. If the keys are found, then it will accept that record.

wrksheet_Key: The worksheet where the records can be found.

row_Key: The row where the records start.

column_Keys(): This is an array with column indices where the keys can be found in:

column_Value(): This is an array with column indices where the values you wish to copy can be found in.

wrkSheet_Output: The worksheet where the results are printed in.

row_Output: The row where the outputs should start printing at.

arrColumnMap(): This is an array which maps the columns specified by column_Value() to a column in the output worksheet.

Return Value: The number of records matched.

Example1:

Assume you have the following records:

The records are written in sheet2 therefor:

Dim wrkSheet_Key As Worksheet
Set wrkSheet_Key = Sheet2


The records start from row 3:

Dim row_Key As Integer
row_Key = 3

Lets say we only need the schools in the US:

Dim strKeys(1 To 1) As String
strKeys(1) = “Us”

 The index for the country column is 3:

Dim column_Keys(1 To 1) As Integer
column_Keys(1) = 3

Lets say we want the results to be printed in Sheet1 Exactly the way it is in sheet2:

Dim row_Output As Integer
Dim wrksheet_Output As Worksheet
Dim column_Values(1 To 5) As Integer
Dim arrColumnMap(1 To 5) As Integer


row_Output = 3
wrksheet_Output = Sheet1
column_Values(1) = 2
column_Values(2) = 3
column_Values(3) = 4
column_Values(4) = 5
column_Values(5) = 6

arrColumnMap(1) = 2
arrColumnMap(2) = 3
arrColumnMap(3) = 4
arrColumnMap(4) = 5
arrColumnMap(5) = 6

After calling the function the results is:

Dim intPrint As Integer
intPrint = RetrieveValueFromKey(strKeys(), wrkSheet_Key, row_Key, _
column_Keys(), column_Value(), wrksheet_Output, row_Output, _
arrColumnMap())

Example2:

In this example we will assume that not only are we looking for US Schools, but we also want the schools to be in california. Changes would only be applied to column_Keys() and str_Keys():

Sub Example2()

Dim wrksheet_Key As Worksheet
Set wrksheet_Key = Sheet2

Dim row_Key As Integer
row_Key = 3

Dim strKeys(1 To 2) As Variant
strKeys(1) = "US"
strKeys(2) = "California"

Dim column_Keys(1 To 2) As Integer
column_Keys(1) = 3
column_Keys(2) = 4

Dim row_Output As Integer
Dim wrksheet_Output As Worksheet
Dim column_Value(1 To 5) As Integer
Dim arrColumnMap(1 To 5) As Integer


row_Output = 3
Set wrksheet_Output = Sheet1
column_Value(1) = 2
column_Value(2) = 3
column_Value(3) = 4
column_Value(4) = 5
column_Value(5) = 6

arrColumnMap(1) = 2
arrColumnMap(2) = 3
arrColumnMap(3) = 4
arrColumnMap(4) = 5
arrColumnMap(5) = 6

Dim intPrint As Integer
intPrint = RetrieveValueFromKey(strKeys(), wrksheet_Key, row_Key, _
column_Keys(), column_Value(), wrksheet_Output, row_Output, _
arrColumnMap())
End Sub