highlighting cells above a certain number

[Lyn Radnell]

Hi,

Can anyone help me?

Out of a group of cells, I would like to highlight any cells over the the number 15 and any highlight in a different colour lower than the number 2

Appreciate any help.

Lyn

 

[Peter_SSs]

Thank you Peter! It works great. But do you know how I can copy or cut any highlighted cells from this sheet on to another sheet?

I don't understand. What is stopping you Copy/Paste or Cut/Paste at the moment?

 

[dadomi]

Sorry Peter, I should be more specific. My spreadsheet will consist of atleast 900 rows of data and cutting and pasting would take a long time. Is there a macro that can cut then paste any rows that have any highlighted cells?

 

[Peter_SSs]

Sorry Peter, I should be more specific. My spreadsheet will consist of atleast 900 rows of data and cutting and pasting would take a long time. Is there a macro that can cut then paste any rows that have any highlighted cells?

Ah, I understand now but I'm about to sigh off for the night. I'll have a think about that tomorrow.

 

[Peter_SSs]

Try this in a copy of your workbook.

Assumptions:
1. Original data (with Conditional Formatting) is on a sheet called "Original". Change the code to suit your sheet name.

2. "Original" has a heading row in row 1.

3. CF is in columns D, E and H

2. Rows with CF colour to be moved to a sheet called "Destination". Change the code to suit your sheet name.

3. "Destination" sheet already exists.

4. If "Destination" already contains any data, it can be removed.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> MoveCFRows()<br>    <SPAN style="color:#00007F">Dim</SPAN> wsO <SPAN style="color:#00007F">As</SPAN> Worksheet, wsD <SPAN style="color:#00007F">As</SPAN> Worksheet<br>    <SPAN style="color:#00007F">Dim</SPAN> UR <SPAN style="color:#00007F">As</SPAN> Range, Crit <SPAN style="color:#00007F">As</SPAN> Range<br>    <SPAN style="color:#00007F">Dim</SPAN> CritCol <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <SPAN style="color:#00007F">Set</SPAN> wsO = Sheets("Original")<br>    <SPAN style="color:#00007F">Set</SPAN> wsD = Sheets("Destination")<br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    wsD.UsedRange.Clear<br>    <SPAN style="color:#00007F">With</SPAN> wsO<br>        <SPAN style="color:#00007F">Set</SPAN> UR = wsO.UsedRange<br>        CritCol = UR.Column + UR.Columns.Count<br>        <SPAN style="color:#00007F">Set</SPAN> Crit = .Cells(1, CritCol).Resize(2)<br>        Crit.Cells(2, 1).Formula = _<br>            "=OR(D2="""",D2>9999999,NOT(ISNUMBER(E2)),H2<200000000,H2>999999999)"<br>        UR.AdvancedFilter _<br>            Action:=xlFilterInPlace, CriteriaRange:=Crit, Unique:=<SPAN style="color:#00007F">False</SPAN><br>        Crit.ClearContents<br>        UR.SpecialCells(xlCellTypeVisible).Copy Destination:=wsD.Range("A1")<br>        UR.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete<br>        <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br>        .ShowAllData<br>        <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">GoTo</SPAN> 0<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[dadomi]

Try this in a copy of your workbook.

Assumptions:
1. Original data (with Conditional Formatting) is on a sheet called "Original". Change the code to suit your sheet name.

2. "Original" has a heading row in row 1.

3. CF is in columns D, E and H

2. Rows with CF colour to be moved to a sheet called "Destination". Change the code to suit your sheet name.

3. "Destination" sheet already exists.

4. If "Destination" already contains any data, it can be removed.


Sub MoveCFRows()
Dim wsO As Worksheet, wsD As Worksheet
Dim UR As Range, Crit As Range
Dim CritCol As Long

Set wsO = Sheets("Original")
Set wsD = Sheets("Destination")

Application.ScreenUpdating = False
wsD.UsedRange.Clear
With wsO
Set UR = wsO.UsedRange
CritCol = UR.Column + UR.Columns.Count
Set Crit = .Cells(1, CritCol).Resize(2)
Crit.Cells(2, 1).Formula = _
"=OR(D2="""",D2>9999999,NOT(ISNUMBER(E2)),H2<200000000,H2>999999999)"
UR.AdvancedFilter _
Action:=xlFilterInPlace, CriteriaRange:=Crit, Unique:=False
Crit.ClearContents
UR.SpecialCells(xlCellTypeVisible).Copy Destination:=wsD.Range("A1")
UR.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error Resume Next
.ShowAllData
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub

The macro worked perfectly! You are an Excel expert!
I did have one question. Is there a way to change this code

Set wsO = Sheets("Original")

? I will be pulling several reports with different file names. Is there a way to use this macro without having to change each file name to "Original"?

Thank you again Peter,
Dadomi

 

[dadomi]

Nevermind my last request. I figured it out! Maybe one day I can write VBA as efficient as you.

dadomi

 

[dadomi]

Actually my macro is interrupted due to that code line. Here is my macro.

Sub Workbook_Open()
  Dim sFil   As String
    Dim sTitle As String
    Dim sWb    As String
    Dim iFilterIndex As Integer
    sTitle = "Raw Report"
    sWb = Application.GetOpenFilename(sFil, iFilterIndex, sTitle)
    Workbooks.Open Filename:=sWb
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Cells.Select
    Application.Run "RunFirst.xls!FILTER"
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.EntireColumn.AutoFit
    Columns("D:D").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=OR(D1="""",D1>9999999)"
    Selection.FormatConditions(1).Interior.ColorIndex = 37
    Columns("E:E").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=NOT(ISNUMBER(E1))"
    Selection.FormatConditions(1).Interior.ColorIndex = 37
    Columns("H:H").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=OR(H1<200000000,H1>999999999)"
    Selection.FormatConditions(1).Interior.ColorIndex = 37
    Cells.Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        Sheets.Add
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "To Be Corrected"
    Dim wsO As Worksheet, wsD As Worksheet
    Dim UR As Range, Crit As Range
    Dim CritCol As Long
    
    Set wsO = Sheets("Original")
    Set wsD = Sheets("To Be Corrected")
    
    Application.ScreenUpdating = False
    wsD.UsedRange.Clear
    With wsO
        Set UR = wsO.UsedRange
        CritCol = UR.Column + UR.Columns.Count
        Set Crit = .Cells(1, CritCol).Resize(2)
        Crit.Cells(2, 1).Formula = _
            "=OR(D2="""",D2>9999999,NOT(ISNUMBER(E2)),H2<200000000,H2>999999999)"
        UR.AdvancedFilter _
            Action:=xlFilterInPlace, CriteriaRange:=Crit, Unique:=False
        Crit.ClearContents
        UR.SpecialCells(xlCellTypeVisible).Copy Destination:=wsD.Range("A1")
        UR.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
    End With
    Application.ScreenUpdating = True
            
    End Sub

The problem lies with this code

Set wsO = Sheets("Original")

. Is there a way to change this from a specific file name to which ever active file I am editing?

 

[Peter_SSs]

A couple of comments about your code.

1. I'd suggest moving "Application.ScreenUpdating = False" from where it is to somewhere right up the top of your code. It will speed your code and stop a lot of screen flicker.

2. You generally do not need to 'Select' things to work with them in vba. Selecting also slows your code. For example, instead of

Columns("A:A").Select
Selection.Delete Shift:=xlToLeft

you can just use

Columns("A").Delete

3. For adding and naming a sheet, try this structure

Sheets.Add.Name = "Some Sheet Name"

4. I'd suggest moving all the 'Dim' statements to the start of the code.

Now, to your actual question.

Is there a way to change this from a specific file name to which ever active file I am editing?

Note that this is not a file name but a worksheet name.

However, if the workbook that you are opening with the code only has one worksheet and that is the sheet you want to treat like my 'Original', then try this

Workbooks.Open Filename:=sWb
Set wsO = ActiveSheet

You would have to have done point 4 above to do this step.

 

[dadomi]

Thank you Peter once again for your expertise. My macro consisted of trial and error and google searches but I am grateful for your help. I plan to expand my knowledge with VBA.