VBA：通过宏将Col C中的单元格数量添加到另一行的单元格中

Question

我想根据类似于下表的数据创建一个宏。如果名称是列 A 是“GA_RE_EM_DEL”，并且在同一行中，列 B 中的日期 >= 12/1/16，那么我希望将该行的列 C 中的金额添加到列 C 中列 A 为“GA_RE_DA_DEL”的行，列 B 中的日期与具有“GA_RE_EM_DEL”的行中的日期匹配。 “GA_RE_EM_DEL”中的任何数量都应更改为 0。

例如，根据下表，单元格 A4 包含“GA_RE_EM_DEL”，并且 B4 中的日期 >= 12/1/16。由于满足这两个条件，我想找到 col A 包含“GA_RE_DA_DEL”的行，并且 col B = B4 中的日期（12/1/16）。符合此条件的行是第 5 行。我想取 C4 中的金额并将其添加到 C5 中的金额（C5 中的最终结果将是 30）。然后 C4 中的金额应更改为 0。我一直在尝试通过循环来完成此操作，但到目前为止还没有创建任何值得发布的内容。这是可以通过宏来完成的吗？

Answer 1

假设您在 Cell E2 中提供日期，请尝试以下操作：

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

我认为你已经很好地描述了这个问题。虽然有很多硬编码的假设。此代码应根据您显示的确切值工作 - 但是必须调整可能更改代码的列更改和比较值。

希望这能让你开始学习 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