Remove data which isn't highlighted and shift it all to the left.

[chanman]

Hi - Some help required please!

Anyone able to help me with the follow?

Book1
	A	B	C	D	E
1	Sample1	Sample2	Sample3	Sample4	Sample5
2	3	A	2	B	G
3	1	3	2	1	1
4	1	A	3	B	3
5	1	4	2	3	1
6	3	3	2	1	3
Sheet1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A1:E6	Cell Value	=3	text	NO

Required output;

Book1
	A	B	C	D	E
1	Sample1	Sample2	Sample3	Sample4	Sample5
2	3
3	3
4	3	3
5	3
6	3	3	3
Sheet2

thanks in advance!

 

[Micron]

If I'm not mistaken (and I often am) you may have to use code because of the cell shifting. AFAIK, the only reliable way is to loop over the range backwards (because it is changing as you delete cells). In your case, if the cell <> 3 delete it, shift left and continue. If you have tens of thousands of rows and many columns, that will likely be be quite slow. How large is the range?

 

[Micron]

Signing off here for the night. In case your range is not too large, I came up with the following (works with your sample data):

Sub KeepOnly3()
Dim Lcol As Long, Lrow As Long, i As Long
Dim sht As Worksheet

On Error GoTo errHandler
Application.EnableEvents = False
Set sht = Sheets("008")
'find the last row and last column with data
Lrow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Lcol = sht.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Do Until Lrow = 1
    For i = Lcol To 1 Step -1
        If Cells(Lrow, i) <> "" And Not CStr(Cells(Lrow, i)) = "3" Then Cells(Lrow, i).Delete Shift:=xlToLeft
    Next i
    Lrow = Lrow - 1
Loop

exitHere:
Application.EnableEvents = True
Exit Sub

errHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume exitHere
End Sub

Put the code in a standard module and change the sheet name in the code to your sheet name.
Test on a backup copy of your workbook.

 

[kevin9999]

Couple of alternatives offered. The first one should do if there aren't too many rows. The second one is better if there are thousands of rows. Just change the sheet name to suit.

Option Explicit
Sub chanman_V1()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")       '<-- *** Change to actual sheet name ***
    Dim r As Range, c As Range
    For Each c In ws.Range("A2", ws.Cells(Rows.Count, "E").End(xlUp))
        If c <> "3" Then
            If r Is Nothing Then Set r = c Else Set r = Union(r, c)
        End If
    Next c
    r.Delete shift:=xlToLeft
    Application.ScreenUpdating = True
End Sub

Sub chanman_V2()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")       '<-- *** Change to actual sheet name ***
    Dim a, b, i As Long, j As Long, k As Long
    ws.Columns("A:E").Interior.Color = xlNone
    a = ws.Range("A2", ws.Cells(Rows.Count, "E").End(xlUp))
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    k = 1
    
    For i = 1 To UBound(a, 1)
        For j = 1 To UBound(a, 2)
            If a(i, j) = "3" Then
                b(i, k) = "3"
                k = k + 1
            End If
        Next j
        k = 1
    Next i
    
    With ws
        .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
        With .UsedRange
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlTextString, String:="3", TextOperator:=xlContains
            .FormatConditions(1).Interior.Color = vbYellow
        End With
    End With
    Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Assuming the values are not the result of formulas & that there will be at least one cell to delete ..

A. If we can use the "3" value to determine what to keep (as the earlier suggestions have done, then you could try this

Sub Move_Left_v1()
  With Range("A2", Range("E" & Rows.Count).End(xlUp))
    .Value = Evaluate("if(" & .Address & "=3,3,True)")
    .SpecialCells(xlConstants, xlLogical).Delete Shift:=xlToLeft
  End With
End Sub

B. If the requirement is to use the cell's colour not being yellow (as indicated in the thread title) like this sample data where the conditional formatting highlights odd numbers and the letter "G" then try the code below.

chanman.xlsm
	A	B	C	D	E
1	Sample1	Sample2	Sample3	Sample4	Sample5
2	3	A	2	B	G
3	1	3	2	1	1
4	1	A	5	B	3
5	1	4	2	3	1
6	3	3	2	1	3
Sheet3

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A2:E6	Expression	=IFERROR(ISODD(A2),A2="G")	text	NO

Sub Move_Left_v2()
  Dim a As Variant
  Dim r As Long, c As Long
 
  With Range("A2", Range("E" & Rows.Count).End(xlUp))
    a = .Value
    For r = 1 To UBound(a)
      For c = 1 To UBound(a, 2)
        If .Cells(r, c).DisplayFormat.Interior.Color <> vbYellow Then a(r, c) = True
      Next c
    Next r
    .Value = a
    .SpecialCells(xlConstants, xlLogical).Delete Shift:=xlToLeft
  End With
End Sub

This is the result of the v2 code on the sample sheet above

chanman.xlsm
	A	B	C	D	E
1	Sample1	Sample2	Sample3	Sample4	Sample5
2	3	G
3	1	3	1	1
4	1	5	3
5	1	3	1
6	3	3	1	3
Sheet3

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A3:D3,A6:D6,A4:C5,A2:B2	Expression	=IFERROR(ISODD(A2),A2="G")	text	NO

 

[Rick Rothstein]

Does this non-looping macro do what you want...

Sub KeepHighlightedOnly()
  With Application.FindFormat
    .Clear
    .Interior.ColorIndex = 0
    With Range("A2", Range("E" & Rows.Count).End(xlUp))
      .Replace "", "", , , , , True, False
      .SpecialCells(xlBlanks).Delete xlShiftToLeft
    End With
    .Clear
  End With
End Sub

 

[chanman]

Thanks all for the responses!
I think my sample data may have mislead some people. Apologies! ( @Micron @kevin9999 ) I over simplified the highlighted values. I required the highlighted cells to be kept regardless of the cell content.

@Peter_SSs v2 worked exactly as required!

@Rick Rothstein - fyi your code left me with an empty sheet

Thank again all, what a great forum and lovely bunch you all are!

 

[kevin9999]

Thanks for the feedback chanman
Although you have a solution, I always feel compelled to correct any previously shared code now new conditions are known. So just for my own benefit:

Option Explicit
Sub chanman_V3()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")       '<-- *** Change to actual sheet name ***
    Dim r As Range, c As Range
    For Each c In ws.Range("A2", ws.Cells(Rows.Count, "E").End(xlUp))
        If c.DisplayFormat.Interior.Color <> vbYellow Then
            If r Is Nothing Then Set r = c Else Set r = Union(r, c)
        End If
    Next c
    r.Delete shift:=xlToLeft
    Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Thanks all for the responses!

You're welcome. Glad we could help. Thanks for the follow-up.

 

[Micron]

I required the highlighted cells to be kept regardless of the cell content.

I don't understand how that can be when in the first post your cf condition is cell equals 3. Oh well.