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.
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.
As per image above, I want to consolidate the charges per category (OA & SNC) in the designated columns (“G” & “H”) on row level.
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
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).