Analyzing A Range Of Cells, Clear Values Immediately Preceeding and Proceeding A Blank Cell

[Ark68]

I am struggling to find a vba solution for a task I need to do with a range of cells in my worksheet. Part of the problem will be trying to explain.

Consider this sample of data that prior code produces.

wsop 22.0327.xlsm
	H	I	J	K	L	M	N	O	P	Q
15	Vacnacy	Vacnacy	Vacnacy		HPE	HPL			HPL
DISPATCH

My goal is to to eliminate any values in the cells except those immediately preceeding and proceeding an empty unshaded cell.
I think what I am aiming for is this ...

wsop 22.0327.xlsm
	H	I	J	K	L	M	N	O	P
16			Vacnacy		HPE	HPL			HPL
DISPATCH

The values in this range are dynamic, and can be an any combination.

 

[BSALV]

as starter, this eliminates the inner grey cells.
No you still have to clear the outer grey cells if the cell aside isn't empty.
Perhaps for you it's easier/more simple, to do everything in the DO ... LOOP WHILE and forget the last part.

Sub Find_Grey()
     With Range("A15")
          Application.FindFormat.Clear
          Application.FindFormat.Interior.Color = .Interior.Color     'this is the format you'e looking for

          With .EntireRow                                       'the range you're looking in
               Set c = .Find("*", .Cells(1, 1), , , , xlNext, , , True)
               If Not c Is Nothing Then
                    firstAddress = c.Address
                    Set UN = c
                    Do
                         Set UN = Union(UN, c)                  'makes a range with all the cells with that interior color
                         Set c = .Find("", c, , , , xlNext, , , True)
                         DoEvents
                    Loop While Not c Is Nothing And c.Address <> firstAddress
               End If
          End With

          If Not UN Is Nothing Then                             'all those cells
               MsgBox UN.Address
               For Each ar In UN.Areas                          'loop through the contigious ranges of those cells
                    MsgBox ar.Address
                    If ar.Cells.Count > 2 Then MsgBox ar.Offset(, 1).Resize(1, ar.Cells.Count - 2).ClearContents     'clear contents of the middle cells
                    If ar.Column = 1 Then ar(1, 1).ClearContents     'do the same if the cell in the 1st column is that colour
                    If ar(1, ar.Columns.Count).Column = ActiveSheet.Columns.Count Then ar(1, ar.Columns.Count).ClearContents     'the same with the last column
               Next
          End If

          Application.FindFormat.Clear
     End With
End Sub

 

[DanteAmor]

Following your example of cells H15 to P15, try this:

Sub ClearValues()
  Dim rng As Range
  Dim ant As Variant
  Dim j As Long
  
  Set rng = Range("H15:P15")
  ant = rng.Cells(1, rng.Columns.Count)
  For j = rng.Columns.Count - 1 To 1 Step -1
    If rng.Cells(1, j).Value = ant Then rng.Cells(1, j).Value = "" Else ant = rng.Cells(1, j)
  Next
End Sub

 

[Ark68]

Thank you both for stepping up to offer your unique solutions. BSALV, I hadn't tested yours simply becuase I opted for Dante's shorter vesion, but it doesn't mean that I don't appreciate the kind contribution.

Dante, thank you. No errors, but you code isn't doing exactly what I am expecting. ("eliminate any values in the cells except those immediately preceeding and proceeding an empty unshaded cell").

In testing, consider this before data range ...

WS 06-Aug-22.xlsx
	H	I	J	K	L	M	N	O	P	Q
14	Vacancy				Vacancy	Vacancy				Vacancy
DS_HPL

After running this code:

set domRng = .Range("H" & dr_trow & ":Q" & dr_trow)
ant = domRng.Cells(1, domRng.Columns.Count)
For j = domRng.Columns.Count - 1 To 1 Step -1
        If domRng.Cells(1, j).Value = ant Then domRng.Cells(1, j).Value = "" Else ant = domRng.Cells(1, j)
Next

This is the result ...

WS 06-Aug-22.xlsx
	H	I	J	K	L	M	N	O	P	Q
14	Vacancy					Vacancy				Vacancy
DS_HPL

The value originally in L14 is missing. As L14 proceeds an empty unshaded cell, it needs to retain the original value of "vacancy".

Thoughts?

 

[DanteAmor]

Hence my comment. the macro works for your first example. Could you give an example of the possible scenarios, with the original data and the expected results. to better understand your requirement, especially in the cases of the start and end of the cells, since they will not have a previous or subsequent cell to compare against. I need to know what the pattern is or what you want as a result.

 

[BSALV]

Sub xxxx()
     Dim bLeft, bRight, c As Range
     With Rows(15)
          On Error Resume Next
          Set c = .SpecialCells(xlConstants)                    'cells with content (not empty, not formulas)
          If c Is Nothing Then MsgBox "no cells", vbCritical: Exit Sub
          On Error GoTo 0
          For Each cl In c.Cells                                'loop through this cells
               If cl.Column = 1 Then bLeft = False Else bLeft = (cl.Offset(, -1).Interior.ColorIndex = xlNone And Len(cl.Offset(, -1).Value) = 0)     'the cell at the LHS is empty and no color
               If cl.Column = ActiveSheet.Columns.Count Then bRight = False Else bRight = (cl.Offset(, 1).Interior.ColorIndex = xlNone And Len(cl.Offset(, 1).Value) = 0)
               If Not bLeft And Not bRight Then cl.ClearContents
          Next
     End With
End Sub

 

[Ark68]

Hi Dante, there really is no pattern to predict. The cells in range H to Q could be any combination of blank unshaded cells and cells that are shaded with or without values.
Basically, if an unshaded cell or a series of contigous unshaded cells is encountered, the cell immediately preceeding and proceeding it that is shaded (grey) with or without a value remains unchanged. All other shaded cells that don't border an empty unshaded cell (or contigious cells) remain shaded, but their values are eliminated.

Here are some examples ....

WS 06-Aug-22.xlsx
	H	I	J	K	L	M	N	O	P	Q
16						HPE		HPE
17		CUL		HPL		HPE		HPE
18	CUL			HPL				HPE
19	CUL		HPL		CWP		CUL	CWP		HPL
20		CUL		CWP		HPL
21		CUL		CWP		HPL		RPE		HPL
22								HPL
23	PLR
24										CUL
DS_HPL

BSalv, in my testing so far, your solution seems to be providing the results. More testing will be needed as I don't think I've covered all the different possible combinations that I may not have considered yet. Thank you!

 

[BSALV]

the macro doesn't look to cells with content that is the result of a formula.
So are there formulas in that range ?

 

[Ark68]

the macro doesn't look to cells with content that is the result of a formula.
So are there formulas in that range ?

No formulas in these cells.

 

[Ark68]

Hi Bsalv, it appears I found one exception in which I don't want your code to do it's thing lol.

Consider this original (before your code is encountered)"

WS 06-Aug-22.xlsx
	H	I	J	K	L	M	N	O	P	Q
14				AUTO	AUTO
DS_RPL

Only in the case of columns K and L, I want to keep both "AUTO"s. In any case, if column K holds "AUTO", column L will always also hold the value "AUTO". "AUTO" will only ever populate columns K and L. Columns K and L could be clear with no shading in some cases. There will never be a mix of clear unshaded cells and "AUTO" shaded cells in column K and L.

ie you will never have these:

WS 06-Aug-22.xlsx
	H	I	J	K	L	M	N	O	P	Q
18	WPL				AUTO
19	WPL			AUTO		CUL
DS_RPL

but you could see any of these combinations:

WS 06-Aug-22.xlsx
	H	I	J	K	L	M	N	O	P	Q
22	WPL			AUTO	AUTO
23	WPL					CUL
24	WPL
25	WPL			CUL
DS_RPL

Note, in row 24 of the examples cell K24 is shaded but doesn't have a value to remain revealed.

I thought I might be able to bypass your code with an "if/then" statement if "AUTO" is encountered, but not sure where, if at all, the value of the cell is dtermnined.

With ws_cs.Range("H" & dr_trow & ":Q" & dr_trow) 'Rows(dr_trow)
        On Error Resume Next
        Set c = .SpecialCells(xlConstants)                    
        If c Is Nothing Then MsgBox "no cells", vbCritical: Exit Sub
       On Error GoTo 0
       If c.value <> "AUTO" Then  '<-this doesn't work
               For Each cl In c.Cells                                'loop through this cells
                       If cl.Column = 1 Then bLeft = False Else bLeft = (cl.Offset(, -1).Interior.ColorIndex = xlNone And Len(cl.Offset(, -1).Value) = 0)     
                       If cl.Column = ActiveSheet.Columns.Count Then bRight = False Else bRight = (cl.Offset(, 1).Interior.ColorIndex = xlNone And Len(cl.Offset(, 1).Value) = 0)
                       If Not bLeft And Not bRight Then cl.ClearContents
               Next
       End If
End With