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