Question

I have a dated CS degree so I understand the basics of VB but I don’t write macros very often and need help solving a particular condition. (…but I understand functions and object oriented programming)

Assume the following:
– Column A contains reference ID’s in alphanumeric form, sorted alphabetically.
– Column B contains strings of text, or blanks.

I’m trying to write a macro that automatically removes any extra rows for each unique reference number based on the contents of the “Notes” in column B. The problem is that if column A has multiple instances of a unique ref number, I need to identify which row contains something in column B. There is one catch: it is possible that the reference number has nothing in column B and should be retained.

To explain further, in the following screenshot I would need to:

• Keep the yellow highlighted rows
• Delete the remaining rows

I tried to show various configurations of how the report might show the data using the brackets on the right and marked in red. Its difficult to explain what I’m trying to do so I figured a picture would show what I need more clearly.

This task is making the report very manual and time consuming.

Answer 1

it’s pretty simple
you just go throug the rows and check whether this row needs to be deleted, an earlier row with this id needs to be deleted or nothing should happen.
in my example i mark these rows and delete them in the end.

Sub foo()
Dim rngSelection As Range
Dim startingRow As Integer
Dim endRow As Integer
Dim idColumn As Integer
Dim noteColumn As Integer
Dim idValuableRow As New Dictionary
Dim deleteRows As New Collection

Set rngSelection = Selection
startingRow = rngSelection.Row
endRow = rngSelection.Rows.Count + startingRow - 1


idColumn = rngSelection.Column
noteColumn = idColumn + 1

For i = startingRow To endRow
    currentID = Cells(i, idColumn)
    If idValuableRow.Exists(currentID) Then
        If Trim(idValuableRow(currentID)("note")) <> "" And Trim(Cells(i, noteColumn)) = "" Then
            deleteRows.Add i
         ElseIf idValuableRow(currentID)("note") = "" And Trim(Cells(i, noteColumn)) <> "" Then
            deleteRows.Add idValuableRow(currentID)("row")
            idValuableRow(currentID)("row") = i
            idValuableRow(currentID)("note") = Cells(i, noteColumn)
        End If
    Else
        Dim arr(2) As Variant
        idValuableRow.Add currentID, New Dictionary
        idValuableRow(currentID).Add "row", i
        idValuableRow(currentID).Add "note", Cells(i, noteColumn)
    End If


Next i
deletedRows = 0
For Each element In deleteRows
    If element <> "" Then
        Rows(element - deletedRows & ":" & element - deletedRows).Select
        Selection.Delete Shift:=xlUp
        deletedRows = deletedRows + 1

        End If
    Next element

End Sub

it could look something like this. the only thing you need is to add Microsoft Scripting Runtime in Tools/References