VBA Help - Loop to Select Range and Apply to a working Macro - Excel 2016

[Johnny Thunder]

Hello All,

I am working on automating a Journal Entry Tool and could use some help with the last part of my tool.

In need of code that will loop thru a range of cells and find a matching value to the Business Unit and log the cell.address in a sum formula.

Full Description:

1. Column A is my Business Unit
2. Column B is my Offset to column A, so if column B contains the text "Offset" this is a row that will need this Dynamic Offsetting Sum formula
3. Column C is my Amount Column

Sample Data
Sheet1

	A	B	C
1	Business Unit (Drop Down)	Offset Entry (Select if line is an offset entry)	Amt
2	Apple		100
3	Banana		200
4	Pear		300
5	Apple	Offset (Here is sample answer	-250
6	Pear	Offset
7	Banana	Offset
8	Apple		150

<tbody>
</tbody>

Spreadsheet Formulas

Cell Formula C5 =-SUM(C2,C8) <tbody> </tbody>

<tbody>
</tbody>

Excel tables to the web >> Excel Jeanie HTML 4

My Working Code to create the Sum Formula - This works with the User manually selecting which cells are matches

Sub Concatenate_Formula()

Dim rSelected   As Range, rOutput As Range, c As Range
Dim sArgs       As String, sArgSep As String, sSeparator As String, sTitle As String
Dim bCol        As Boolean, bRow As Boolean
Dim vbAnswer    As VbMsgBoxResult
Dim lTrim       As Long

'Set variables
Set rOutput = ActiveCell
bCol = False
bRow = False
sSeparator = ""
sTitle = "CONCATENATE"

    'Prompt user to select cells for formula
    On Error Resume Next
    Set rSelected = Application.InputBox(Prompt:= _
                    "Select cells to create formula", _
                    Title:=sTitle & " Creator", Type:=8)
    On Error GoTo 0
    
    'Only run if cells were selected and cancel button was not pressed
    If Not rSelected Is Nothing Then
        
        'Set argument separator for concatenate or ampersand formula
        sArgSep = ","
      
        'Create string of cell references
        For Each c In rSelected.Cells
            sArgs = sArgs & c.Address(bRow, bCol) & sArgSep
            If sSeparator <> "" Then
                sArgs = sArgs & Chr(34) & sSeparator & Chr(34) & sArgSep
            End If
        Next
        
        'Trim extra argument separator at the end of formula
        lTrim = IIf(sSeparator <> "", 4 + Len(sSeparator), 1)
        sArgs = Left(sArgs, Len(sArgs) - lTrim)


        rOutput.Formula = "=-Sum(" & sArgs & ")"
        
    End If


End Sub

 

[Jeffrey Mahoney]

In the example of B5, you want the macro to sum all the values in Column C that match "Apple"? You want this to be a formula?
Can the formula be:
=-SUMIFS($C2:$C1000,$A2:$A1000,A5)
Or are you trying to just sum the values up to that point? In which case it could be: =-SUMIFS($C2:$C5,$A2:$A5,A5)

This is my first stab at the code. It seems to me that you might need more. Tell me if I'm wrong, the Offset value to that point should only sum the values that haven't been OFFSET before. We may need to create another column to help track if the values have been offset previously. Or have the macro look for the last offset value for that Business unit and only SUMIFS from that point down.

Sub AddOffsetFormula()
  Dim R As Range
  Dim Cel As Range
  Dim BegRow As Long        'First row of data
  Dim OSCol As Long         'Offset column
  Dim BUCol As Long         'Business unit column
  Dim AmtCol As Long        'Amount Column
  Dim A As String
  Dim BUAddr As String      'Address of BU range down to the cell
  Dim AmtAddr As String     'Address of Amt range down to the cell
  Dim BUCritAddr As String  'Address of Name of Current BU
  
  BegRow = 2
  OSCol = 2
  BUCol = 1
  AmtCol = 3
  
  
  Set Cel = Cells(BegRow, OSCol)
  Set R = Range(Cel, Cells(Cells.Rows.Count, OSCol).End(xlUp))
  
  For Each Cel In R
    A = UCase(Cel.Value)
    If InStr(A, "OFFSET") > 0 Then
      BUAddr = Range(Cells(BegRow, BUCol), Cells(Cel.Row, BUCol)).Address
      AmtAddr = Range(Cells(BegRow, AmtCol), Cells(Cel.Row, AmtCol)).Address
      BUCritAddr = Cells(Cel.Row, BUCol).Address
      Cel.Formula = "=SUMIFS(" & AmtAddr & "," & BUAddr & "," & BUCritAddr & ")"
    End If
  Next Cel
  
End Sub

 

[Johnny Thunder]

To answer your question, yes I need the code to build the sum formula like =-"Sum(A2,A8)" For the Apple scenario.

I got to the same point of your code here with a different route but unfortunately its not going to work.

Your code doesn't capture the last row (8) with the Business Unit "Apple".

The problem really comes from having two offset lines on top of each other because then the range style formulas like what your code is doing cause a circular reference.

----
I've researched and modified the below code to solve the issue of incrementally building the SUM formula but I am having the hardest time finding out where to insert my SUM Formula with the below code.

Currently, on the first pass the code returns "$A$2,$A$8" but as it continues to loop and pick up the next Offset (Business Unit) it continues to append to the "$A$2,$A$8" instead of clearing the old StrResults and giving a new string for the new Offset (Business Unit).

If I am not being clear let me know and I can elaborate further

Sub CreateDynamicSum()


Dim strResults As String, StrSearch As String
Dim Sht As Worksheet
Dim sFirstAddress
Dim DataSet As Range, Cell As Range, rFND As Range, FoundData As Range
Dim LastR As Long, ltrim As Long


Set Sht = Sheets("Input")
LastR = Sheets("Input").Cells(Rows.Count, "B").End(xlUp).Row  '2 refers to the row to start on
Set DataSet = Sht.Range("E12:E" & LastR & "")
Set FoundData = Range("D12:D" & LastR & "")
   
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    
    For Each Cell In DataSet
        If Cell.Value = "Offset" Then
            Cell.Select
                StrSearch = Cell.Offset(0, -1).Value
                MsgBox StrSearch
    
    'Searches for String Variable "StrSearch"
    Set rFND = FoundData.Find(What:=StrSearch, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlRows, SearchDirection:=xlNext, MatchCase:=False)
        If Not rFND Is Nothing Then
          sFirstAddress = rFND.Address
            Do
                If strResults = vbNullString Then
                    strResults = rFND.Address & "," 'Find the first occurance of the Search String
                Else
                    strResults = strResults & rFND.Address & "," 'Builds on the search string
                End If
                Set rFND = FoundData.FindNext(rFND)
                Loop While Not rFND Is Nothing And rFND.Address <> sFirstAddress
        
           End If
        End If

'Trim extra argument separator at the end of formula
ltrim = IIf("" <> "", 4 + Len(""), 1)
strResults = Left(strResults, Len(strResults) - ltrim)

'Somewhere in here I would enter my Sum formula Cell.Offset(0,7).Formula = "Sum(" & StrResults & ")"
               
         Next 'Moves to the next Cell

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub