CODEWITHSUNDEEP
vbaexcel
Neo
Neo

Reputation: 49

VBA finding value and put it in specific column

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.

Upvotes: 1

Views: 226

Answers (2)

AntiDrondert
AntiDrondert

Reputation: 1149

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, _
                                       rngData.Columns.Count).Value
    '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))
    Next
End Sub

Upvotes: 1

SJR
SJR

Reputation: 23081

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

Upvotes: 1

Related Questions