Help on Project - VBA or Macros

dfuhrman840 I'm not going to bother attempting the conditional formatting, as I have a solution (code is below).

The examples you posted on Nov. 18 were useful. I did not initially see your response, hence the delay. But your text brings up one more question: If the Expense Amt values are different, but the Expense # and GL Codes are identical, should the rows be condensed? My code currently does not include Expense Amt in the decision to condense, only in the accumulation ... but that's easy to change.

In the absence of direct answers to my questions, I derive/assume:

1. In the interest of safety, my solution creates a new worksheet.
2. Yes, you want the individual rows deleted (after aggregation into one row).
3. not applicable
4. no longer care
5. Amt did refer to a monetary value.
6. I still don't have an answer for this. See below.
7. If there are data discrepancies in columns B-D between rows that have the same values in columns A and F-L, I will issue a warning, highlight the different data in the lower row, and not condense the row.

To make question 6 clearer, consider the two rows shown in the picture. If the Expense # values for those two rows are the same, should the rows be condensed? (That would be more difficult to do.) Or is that condition so improbable that the code need not be concerned with it?

As I noted before, you are not required to sort the rows before running my procedure.

Sub CondenseExpenseItems()
'   This procedure:
'       1 - copies a user-specified worksheet to a new worksheet,
'       2 - adds a column of data (the original row number)
'       3 - scans through the rows, condensing "duplicates" as identified
'           in columns A and F-L, and summing values in column E (exceptions
'           are made if differing data is identified in columns B-D, and
'           a warning is given)
'       4 - displays a summary message
'   The relevant workbook must be open when this procedure is invoked; it
'       does not have to be the active workbook.

    Const PROCEDURE_NAME = "CondenseExpenseItems"
    Const in4LAST_HEADER_ROW    As Long = 1 'If header rows are added or _
            removed, update this value.
    Const strCOLUMN_FOR_ORIG_ROW_NUM = "M"
    
    Dim strActivity     As String   'what the code is doing
    Dim strMessage      As String   'message to the user
    Dim in4UserResponse As VbMsgBoxResult
    Dim blnCancelProcessing As Boolean
    
    Dim strWorkbookName As String
    Dim objWorkbook     As Workbook
    Dim strOrigWkshtName    As String
    Dim strNewWkshtName     As String
    Dim objWorksheet    As Worksheet
    
    Dim in4OrigLastDataRow  As Long
    Dim in4LastDataRow  As Long 'NOTE: Once row condensing starts, this _
            value will decrease.
    Dim in4Row      As Long
    Dim strRow      As String
    Dim in4AggRow   As Long 'row being checked for aggregation
    Dim blnDiscrepancyFound     As Boolean
    Dim blnAggregationOccurred  As Boolean
    Dim in4RowsWithAccum    As Long
    Dim in4RowsDeleted  As Long
    
    Dim vntExpenseNum   As Variant
    Dim vntExpenseAmt   As Variant
    Dim vntGLCode1  As Variant
    Dim vntGLCode2  As Variant
    Dim vntGLCode3  As Variant
    Dim vntGLCode4  As Variant
    Dim vntGLCode5  As Variant
    Dim vntGLCode6  As Variant
    Dim vntGLCode7  As Variant
    
    '----
    On Error GoTo CondenseItems_ErrHndlr
    
    '----   PHASE 1: Determine the workbook and worksheet to be edited.
    strActivity = "Workbook selection"
    strMessage = "Which Excel workbook should be used?"
    strWorkbookName = InputBox(strMessage, PROCEDURE_NAME, ActiveWorkbook.Name)
    If strWorkbookName = "" Then Exit Sub
    '
    On Error Resume Next
    Set objWorkbook = Application.Workbooks(strWorkbookName)
    On Error GoTo CondenseItems_ErrHndlr
    If objWorkbook Is Nothing Then
        strMessage = "Workbook " & strWorkbookName _
                & " is not open/cannot be used."
        Call MsgBox(strMessage, vbCritical Or vbOKOnly, PROCEDURE_NAME)
        Exit Sub
    End If
    objWorkbook.Activate
    '  --
    strActivity = "Worksheet selection"
    strMessage = "Which worksheet should be used?"
    strOrigWkshtName = InputBox(strMessage, PROCEDURE_NAME, ActiveSheet.Name)
    If strOrigWkshtName = "" Then GoTo CondenseItems_Exit
    '
    On Error Resume Next
    Set objWorksheet = objWorkbook.Sheets(strOrigWkshtName)
    On Error GoTo CondenseItems_ErrHndlr
    If objWorksheet Is Nothing Then
        strMessage = "Worksheet " & strOrigWkshtName _
                & " is not present."
        Call MsgBox(strMessage, vbCritical Or vbOKOnly, PROCEDURE_NAME)
        Exit Sub
    End If
    '  --   Make a copy of the original worksheet.
    strActivity = "Copying of worksheet"
    strNewWkshtName = strOrigWkshtName & "_A"
    objWorksheet.Copy After:=objWorksheet
    Set objWorksheet = objWorkbook.Sheets(strOrigWkshtName & " (2)")
    objWorksheet.Name = strNewWkshtName
    objWorksheet.Activate
    DoEvents
    
    '----   PHASE 2: Add a column containing row numbers, counting populated
    '       rows as you go.
    strActivity = "Storing of original row numbers"
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
    blnCancelProcessing = False
    With objWorksheet
        For in4Row = in4LAST_HEADER_ROW + 1 To 1048576#
            strRow = CStr(in4Row)
            If .Range("A" & strRow).Value = "" Then
                '...the end of the data rows has been found.
                Exit For
            ElseIf .Range(strCOLUMN_FOR_ORIG_ROW_NUM & strRow).Value <> "" Then
                strMessage = "Content was found in a cell that was " _
                        & "expected to be empty: " & strCOLUMN_FOR_ORIG_ROW_NUM _
                        & strRow
                Call MsgBox(strMessage, vbCritical Or vbOKOnly, PROCEDURE_NAME)
                GoTo CondenseItems_Exit
            End If
            .Range(strCOLUMN_FOR_ORIG_ROW_NUM & strRow).Value = in4Row
            in4LastDataRow = in4Row
        Next in4Row
    End With
    in4OrigLastDataRow = in4LastDataRow
    
    '----   PHASE 3: Scan the rows, condensing "duplicates" into the
    '       aggregation row (the first-encountered among the "duplicates").
    strActivity = "Scanning rows"
    in4AggRow = in4LAST_HEADER_ROW + 1
    With objWorksheet
        Do While in4AggRow < in4LastDataRow
            '  --   Capture values that identify aggregation sets, and
            '       the amount(s) to be accumulated.
            strRow = CStr(in4AggRow)
            blnAggregationOccurred = False
            vntExpenseNum = .Range("A" & strRow).Value
            vntGLCode1 = .Range("F" & strRow).Value
            vntGLCode2 = .Range("G" & strRow).Value
            vntGLCode3 = .Range("H" & strRow).Value
            vntGLCode4 = .Range("I" & strRow).Value
            vntGLCode5 = .Range("J" & strRow).Value
            vntGLCode6 = .Range("K" & strRow).Value
            vntGLCode7 = .Range("L" & strRow).Value
            vntExpenseAmt = .Range("E" & strRow).Value
            '  --   Scan for "duplicates" (from the bottom up).
            For in4Row = in4LastDataRow To in4AggRow + 1 Step -1
                strRow = CStr(in4Row)
                strActivity = "Scanning rows"
                If vntExpenseNum = .Range("A" & strRow).Value _
                And vntGLCode1 = .Range("F" & strRow).Value _
                And vntGLCode2 = .Range("G" & strRow).Value _
                And vntGLCode3 = .Range("H" & strRow).Value _
                And vntGLCode4 = .Range("I" & strRow).Value _
                And vntGLCode5 = .Range("J" & strRow).Value _
                And vntGLCode6 = .Range("K" & strRow).Value _
                And vntGLCode7 = .Range("L" & strRow).Value _
                Then    '...we've found a "duplicate"
                    '  --   Check for a discrepancy (inconsistency) in data
                    '       between this row and the aggregation row.
                    blnDiscrepancyFound = False
                    If .Range("B" & strRow).Value <> .Range("B" & in4AggRow).Value Then
                        blnDiscrepancyFound = True
                        .Range("B" & strRow).Interior.Color = vbYellow
                    End If
                    If .Range("C" & strRow).Value <> .Range("C" & in4AggRow).Value Then
                        blnDiscrepancyFound = True
                        .Range("C" & strRow).Interior.Color = vbYellow
                    End If
                    If .Range("D" & strRow).Value <> .Range("D" & in4AggRow).Value Then
                        blnDiscrepancyFound = True
                        .Range("D" & strRow).Interior.Color = vbYellow
                    End If
                    If blnDiscrepancyFound Then
                        strMessage = "Discrepant data was found in original rows " _
                                & .Range("M" & CStr(in4AggRow)).Value & " and " _
                                & .Range("M" & strRow).Value
                        in4UserResponse = MsgBox(strMessage, vbExclamation _
                                Or vbOKCancel, PROCEDURE_NAME)
                        If in4UserResponse = vbCancel Then
                            blnCancelProcessing = True
                            Exit For
                        End If
                        GoTo CompareNextDataRow
                    End If
                    '  --   Condense this row.
                    strActivity = "Condensing rows"
                    blnAggregationOccurred = True
                    '  Mark the row.
                    .Range(strCOLUMN_FOR_ORIG_ROW_NUM & strRow).Value = _
                    .Range(strCOLUMN_FOR_ORIG_ROW_NUM & strRow).Value * -1
                    '   Accumulate, and update the aggregation row.
                    vntExpenseAmt = vntExpenseAmt + .Range("E" & strRow).Value
                    .Range("E" & in4AggRow).Value = vntExpenseAmt
                    '   Delete the row.
                    .Range("A" & strRow).EntireRow.Delete Shift:=xlShiftUp
                    in4LastDataRow = in4LastDataRow - 1
                    in4RowsDeleted = in4RowsDeleted + 1
                End If
CompareNextDataRow:
            Next in4Row
            '  --
            If blnAggregationOccurred Then
                in4RowsWithAccum = in4RowsWithAccum + 1
            End If
            If blnCancelProcessing Then
                Exit Do
            End If
            in4AggRow = in4AggRow + 1
        Loop
    End With
    
    '----   PHASE 4: Display a summary message.
    strMessage = Format$(in4RowsWithAccum + in4RowsDeleted, "#,###,##0") _
            & " rows were condensed into " _
            & Format$(in4RowsWithAccum, "#,###,##0") & " rows."
    Call MsgBox(strMessage, vbInformation Or vbOKOnly, PROCEDURE_NAME)
    
CondenseItems_Exit:
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
    If Not objWorksheet Is Nothing Then
        objWorksheet.Activate
    End If
    Set objWorksheet = Nothing
    Set objWorkbook = Nothing
    Exit Sub

CondenseItems_ErrHndlr:
    Dim in4ErrorCode    As Long
    Dim strErrorDescr   As String
    '  --   Capture info.
    in4ErrorCode = Err.Number
    strErrorDescr = Err.Description
    '  --
    strMessage = "Error " & in4ErrorCode & " occurred during " _
            & strActivity & ":" & vbCrLf & strErrorDescr & vbCrLf & vbCrLf _
            & strWorkbookName & " " & strNewWkshtName & "  " & CStr(in4AggRow)
    Call MsgBox(strMessage, vbCritical Or vbOKOnly, PROCEDURE_NAME)
    '  --
    Application.ScreenUpdating = True
    Resume CondenseItems_Exit
    Resume  'inaccessible, but retained for debugging
End Sub

I had some trouble getting the new worksheet to appear automatically.  I think I got that fixed, but if the new worksheet does not appear, click on an existing worksheet's tab.