Home » excel » excel – VBA finding value and put it in specific column

excel – VBA finding value and put it in specific column

Posted by: admin May 14, 2020 Leave a comment


Hope you you can help me here. I have a repetitive task every week, which I could do the same way every single time through Excel formulas, but I am looking for a more automated way of going about this.

Data example

What I want to achieve is to set-up a dynamic range that will look for multiple key words such as in this case “OA” & “SNC” and if it matches it will return the value in the column G & H respectively. At the same time it has to skip blank rows. What is the best way to go about this?

I figured it shouldn’t be too hard, but I cannot figure it out.

Expected results

As per image above, I want to consolidate the charges per category (OA & SNC) in the designated columns (“G” & “H”) on row level.

How to&Answers:

My approach to the task

Procedure finds data range, loops through it’s values, adding unique values to the dictionary with sum for specific row and then loads all these values along with sums per row.

Option Explicit
Sub CountStuff()
    Dim wb As Workbook, ws As Worksheet
    Dim lColumn As Long, lRow As Long, lColTotal As Long
    Dim i As Long, j As Long
    Dim rngData As Range, iCell As Range
    Dim dictVal As Object
    Dim vArr(), vArrSub(), vArrEmpt()

    'Your workbook
    Set wb = ThisWorkbook
    'Set wb = Workbooks("Workbook1")

    'Your worksheet
    Set ws = ActiveSheet
    'Set ws = wb.Worksheets("Sheet1")

    'Number of the first data range column
    lColumn = ws.Rows(1).Find("1", , xlValues, xlWhole).Column
    'Number of the last row of data range
    lRow = ws.Cells(ws.Rows.Count, lColumn).End(xlUp).Row
    'Total number of data range columns
    lColTotal = ws.Cells(1, lColumn).End(xlToRight).Column - lColumn + 1
    'Data range itself
    Set rngData = ws.Cells(1, lColumn).Resize(lRow, lColTotal)
    'Creating a dictionary
    Set dictVal = CreateObject("Scripting.Dictionary")
    'Data values -> array
    vArr = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, _
    'Empty array
    ReDim vArrEmpt(1 To UBound(vArr, 1))
    'Loop through all values
    For i = LBound(vArr, 1) To UBound(vArr, 1)
        For j = LBound(vArr, 2) To UBound(vArr, 2)
            'Value is not numeric and is not in dictionary
            If Not IsNumeric(vArr(i, j)) And _
                    Not dictVal.Exists(vArr(i, j)) Then
                'Add value to dictionary
                dictVal.Add vArr(i, j), vArrEmpt
                vArrSub = dictVal(vArr(i, j))
                vArrSub(i) = vArr(i, j - 1)
                dictVal(vArr(i, j)) = vArrSub
            'Value is not numeric but already exists
            ElseIf dictVal.Exists(vArr(i, j)) Then
                vArrSub = dictVal(vArr(i, j))
                vArrSub(i) = vArrSub(i) + vArr(i, j - 1)
                dictVal(vArr(i, j)) = vArrSub
            End If
        Next j
    Next i
    'Define new range for results
    Set rngData = ws.Cells(1, lColumn + lColTotal - 1). _
        Offset(0, 2).Resize(1, dictVal.Count)
    'Load results
    rngData.Value = dictVal.Keys
    For Each iCell In rngData.Cells
        iCell.Offset(1, 0).Resize(lRow - 1).Value _
            = Application.Transpose(dictVal(iCell.Value))
End Sub


I’ve used a simple custom function, possibly overkill as this could be done with worksheet formulae, but given that your ranges can vary in either direction…

Function altsum(r As Range, v As Variant) As Variant

Dim c As Long

For c = 2 To r.Columns.Count Step 2
    If r.Cells(c) = v Then altsum = altsum + r.Cells(c - 1)
Next c

If altsum = 0 Then altsum = vbNullString

End Function

Example below, copy and formula in F2 across and down (or apply it one go with another bit of code).

enter image description here