Highlight Adjacent Cells Above Highlighted Cell

[reese]

Trying to write a macro that will find highlighted cells, then highlight the adjacent cells containing the rest of an entry

Background info: Working with a large contacts database (800,000 Rows) where data is not uniformly formatted: telephone numbers, addresses, contact names inconsistently broken along multiple cell-rows

Objective: Extracting complete contact entries with highlighted cells

Problem: Complete entries span 5-6 contiguous / adjacent cells, but only 1-2 cells in a given entry have been highlighted

Entries are formatted in single column, 5-6 rows, separated vertically by cell containing ( ," ), and 2 blank cells between groups of 2-3 entries

Bonus Info: The ultimate purpose is to build a clean contacts database, so the next step would be to copy the highlighted entries into a new spreadsheet. If there is a way to highlight only those separators (,"") adjacent to desired entries in another color, the data would be completely prepared for extraction.

See Current and Outcome examples below....

Current Format Example:

Row 1: ,""

Row 2: Business Name 1

Row 3: Business Name 2

Row 4: Address 1 Row 5: Address 2 Row 6: Contact Info 1 Row 7: Contact Info 2

Row 8: ,""

Row 9: Business Name 1 Row 10: Business Name 2 Row 11: Address 1 Row 12: Address 2 Row 13: Contact Info 1 Row 14: Contact Info 2 Row 15: ,"" Row 16: Business Name 1 Row 17: Address 1 Row 18: Contact Info 1 Row 19: ,"" Row 20: <blank> Row 21: <blank> Row 22: ,""

Outcome Format Example:

Row 1: ,""

Row 2: Business Name 1

Row 3: Business Name 2

Row 4: Address 1 Row 5: Address 2 Row 6: Contact Info 1 Row 7: Contact Info 2

Row 8: ,""

Row 9: Business Name 1 Row 10: Business Name 2 Row 11: Address 1 Row 12: Address 2 Row 13: Contact Info 1 Row 14: Contact Info 2 Row 15: ,"" Row 16: Business Name 1 Row 17: Address 1 Row 18: Contact Info 1 Row 19: ," Row 20: <blank> Row 21: <blank> Row 22: ,""

[Kenneth Hobs]

Welcome to the forum!

To get the best help, help us help you by attaching a short obfuscated file with before and after data. Click the Go Advanced button in a replay to get the paperclip icon to attach a file.

[jonh]

Private col As New Collection
Sub highlight()
    Dim found As Boolean, c As Range, i As Long, clr As Long, ptn As Integer, x As Byte
    With ActiveSheet
        Do
            i = i + 1
            Select Case Trim(.Cells(i, 1).Text)
            Case ""
                If x = 255 Then Exit Sub
                x = x + 1
            Case ","""""
                If found Then
                    For Each c In col
                        With c.Interior
                            .Pattern = ptn
                            .Color = clr
                        End With
                    Next
                    found = False
                End If
                Set col = New Collection
            Case Else
                x = 0
                col.Add .Cells(i, 1)
                If Not found Then
                    With .Cells(i, 1).Interior
                        If .Pattern <> xlNone Then
                            found = True
                            clr = .Color
                            ptn = .Pattern
                        End If
                    End With
                End If
            End Select
        Loop
    End With
End Sub