VBA: Add Amount of Cell in Col C to Cell in Another Row via Macro

Question

I would like to create a macro based on data similar to the table below. If the name is column A is "GA_RE_EM_DEL" and in that same row the date in col B is >= 12/1/16, then I would like to have the amount in col C for that row added to the col C in the row where col A is "GA_RE_DA_DEL", the date in col B matches the date from the row with "GA_RE_EM_DEL". Whatever amount was in "GA_RE_EM_DEL" should then be changed to 0.

For example, based on the table below, cell A4 contains "GA_RE_EM_DEL", and the date in B4 is >= 12/1/16. Since both criteria are met, I would like to find the row where col A contains "GA_RE_DA_DEL", and col B = the date that was in B4 (12/1/16). The row that meets this criteria is row 5. I would like to take the amount in C4 and add it to the amount in C5 (the end result in C5 would then be 30). Then the amount in C4 should be changed to 0. I have been trying to get this done with a loop, but have not been able to create anything worth posting thus far. Is that something that can be done via a macro?

Answer 1

Assuming you are providing date in Cell E2 try the following:

Sub Demo()
    Dim rFound As Range, rng As Range, foundRng As Range
    Dim strName1 As String, strName2 As String
    Dim count As Long, LastRow As Long

    Set rng = Range("A:A")

    On Error Resume Next
    'assign strings to be searched
    strName1 = "GA_RE_EM_DEL"
    strName2 = "GA_RE_DA_DEL"

    'loop two times to find two strings "GA_RE_EM_DEL" and "GA_RE_DA_DEL"
    For i = 1 To 2
        If i = 1 Then
            strName = strName1
        Else
            strName = strName2
        End If

        'find the string in Column A
        With rng
            Set rFound = .Find(What:=strName, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
            If Not rFound Is Nothing Then
                FirstAddress = rFound.Address
                Do
                    'if string found compare the date
                    If rFound.Offset(0, 1) >= DateValue(Range("E2").Value) Then
                        If i = 1 Then
                            Set foundRng = rFound
                        End If
                        Exit Do
                    Else
                        Set rFound = .FindNext(rFound)
                    End If
                Loop While Not rFound Is Nothing And rFound.Address <> FirstAddress
            End If
        End With
    Next i
    On Error GoTo 0

    'adding values
    If Not foundRng Is Nothing And Not rFound Is Nothing Then
        rFound.Offset(0, 2).Value = rFound.Offset(0, 2).Value + foundRng.Offset(0, 2).Value
        foundRng.Offset(0, 2).Value = 0
    Else
        MsgBox "No Data Found"
    End If
End Sub

Answer 2

I think you;ve described the problem well. There's a lot of hardcoded assumptions though. This code should work based on the exact values you've displayed - however with column changes and comparison values that might change the code will have to be tweaked.

Hopefully this will get you up and running in your quest to learn VBA

Option Explicit

Public Sub RedoCells()

    Const LOOKUP_START  As String = "GA_RE_EM_DEL"
    Const LOOKUP_MATCH  As String = "GA_RE_DA_DEL"

    Const MIN_DATE      As Date = #12/1/2016#

    Const LOOKUP_COL    As Integer = 1
    Const DATE_COL      As Integer = 2
    Const VALUE_COL     As Integer = 3

    Dim rge         As Range

    Dim intRow      As Integer
    Dim intCol      As Integer
    Dim intRows     As Integer
    Dim intColumns  As Integer

    Dim intLastRow  As Integer

    Dim strLookup   As String
    Dim datLookup   As Date

    Dim varData As Variant

    ' Select all data
    Range("A1").CurrentRegion.Select
    Set rge = Range("A1").CurrentRegion

    varData = Selection

    intRows = Selection.Rows.Count
    For intRow = 2 To intRows
        strLookup = varData(intRow, LOOKUP_COL)

        ' Check for Row Match
        If (strLookup = LOOKUP_START) And (varData(intRow, DATE_COL) >= MIN_DATE) Then

            ' Start Looking for match at next row
            intNextRow = intRow

            Do Until (varData(intNextRow, LOOKUP_COL) = LOOKUP_MATCH) Or varData(intNextRow, LOOKUP_COL) = ""
                intNextRow = intNextRow + 1

                ' Check for matching date for row value
                If varData(intNextRow, DATE_COL) = varData(intRow, DATE_COL) Then

                    ' Add previous value to current value
                    varData(intNextRow, VALUE_COL) = varData(intNextRow, VALUE_COL) + varData(intRow, VALUE_COL)

                    ' Zero out previous value
                    varData(intRow, VALUE_COL) = 0
                    Exit Do
                End If
            Loop

        End If

    Next intRow

    ' Save all data back to previous range
    Range("A1").CurrentRegion = varData
End Sub