highlight cell if isblank vba - vba

Hi i have the following code but it prommpts an error range of object_worksheet failed. I'm not sure what i'm doing wrong (i've found the vba code using record macro and simply copy and pasted except i've replaced all of selection to ws.range(emptyrow) to indicate the range is up to the last cell with values. Also, if i were to change the sub to sub highlightemptycell_change() and have if statement as such: "if any cells are changed then do the following" how would i write that in a vba language?
sub highlightemptycell()
Dim ws As Worksheet
Dim r As Range
Dim emptyrow As Long
Dim err As Range
Set ws = Worksheets("Master")
emptyrow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 '<<< safer....
ws.Range(emptyrow).FormatConditions(1).StopIfTrue = False
ws.Range(emptyrow).FormatConditions.Add Type:=xlExpression, Formula1:= _
"=ISBLANK(ws.range(emptyrow)"
ws.Range(emptyrow).FormatConditions(ws.Range(emptyrow).FormatConditions.Count).SetFirstPriority
With ws.Range(emptyrow).FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
End With

I'm not sure exactly what you are doing. In particular, I'm not sure of the significance of this line,
ws.Range(emptyrow).FormatConditions(1).StopIfTrue = False
especially when there are no conditional formats in the cell at the time it is executed.
But the following macro seems to do what yours would do if it were cleaned up a bit and written with proper syntax
Option Explicit
Sub highlightemptycell()
Dim ws As Worksheet
Dim r As Range
Dim emptyrow As Long
Dim err As Range
Dim rEmptyRow As Range '<-- range object added to use below
Set ws = Worksheets("Master")
Set rEmptyRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(rowoffset:=1) '<<< safer....
With rEmptyRow.FormatConditions
If .Count > 0 Then .Item(1).StopIfTrue = False
.Add Type:=xlExpression, Formula1:= _
"=ISBLANK(" & rEmptyRow.Address & ")"
.Item(.Count).SetFirstPriority
With .Item(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
End With
End With
End Sub

Related

Translating Conditional Formatting to VBA codes

I have to apply two conditional formatting to my data in a sheet called "Report" (num of rows are not fixed). I can do these via the "Manage Rules" option via conditional formatting. So I tried to record macro but unfortunately I don't see any codes recorded.
Conditional Formatting 1:
=$F5="NH Orientation" , then Color (242,220,219)
Conditional Formatting 2:
=OR($O4<4,$G4="Elective"), then color (242,220,219)
Post which I will cut and paste the colored cells in row 2 and below in another sheet called "Removed"
I want to have these conditions in macro in my excel.
You decide how to tweak but the following are the main elements:
Option Explicit
Public Sub AddRules()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = ThisWorkbook.Worksheets("Report") ' change
Dim rule1 As FormatCondition
Dim rule2 As FormatCondition
Dim lastRow As Long
lastRow = GetLastRow(ws, 1)
If lastRow < 4 Then
MsgBox "Invalid number of rows"
Exit Sub
End If
With ws.Range("A4:V" & lastRow)
.FormatConditions.Delete
Set rule1 = .FormatConditions.Add(Type:=xlExpression, _
Formula1:="=$F5=""NH Orientation""")
rule1.StopIfTrue = True 'Change as required
Set rule2 = .FormatConditions.Add(Type:=xlExpression, _
Formula1:="=OR($O4<4,$G4=""Elective"")")
Dim i As Long
For i = 1 To 2
With .FormatConditions(i)
With .Interior
.PatternColorIndex = xlAutomatic
.Color = RGB(242, 220, 219)
.TintAndShade = 0
End With
End With
Next i
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
Reference:
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/formatconditions-add-method-excel
I modified as below and it is working now. Please advise if this can be improved.
Sub AddRules()
Dim ws As Worksheet
Set ws = Sheets("Report")
Dim lastRow As Long
lastRow = GetLastRow(ws, 1)
If lastRow < 4 Then
MsgBox "Invalid number of rows"
Exit Sub
End If
With ws.Range("A4:V" & lastRow)
.FormatConditions.Delete
Set rule1 = .FormatConditions.Add(Type:=xlExpression, _
Formula1:="=$F4=""NH Orientation""")
With rule1
.Interior.Color = RGB(242, 250, 219)
End With
End With
With ws.Range("A4:V" & lastRow)
Set rule2 = .FormatConditions.Add(Type:=xlExpression,Formula1:="=AND($O4<4,$G4=""Elective"")")
With rule2
.Interior.Color = RGB(242, 210, 219)
End With
End With
End Sub
Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function

Highlight all rows equal to value in cell foobar

I am trying to code this procedure to highlight all rows of which have a value of "N" in their respective row within Column N
I am not too familiar with coding VBA formatting and I cannot get this procedure to function
Sub highlight_new_pos()
Dim rng As Range, lCount As Long, LastRow As Long
Dim cell As Object
With ActiveSheet 'set this worksheet properly!
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In .Range("N2:N" & LastRow)
If cell = "N" Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next cell
End With
End Sub
Option Explicit
Sub highlight_new_pos()
Dim cel As Object
With ActiveSheet
For Each cel In .Range("N2:N" & .Cells(.Rows.Count, 14).End(xlUp).Row)
If UCase(cel.Value2) = "N" Then cel.Interior.Color = 65535
Next
End With
End Sub
This will be faster if you have a lot of rows:
Sub highlight_new_pos1()
Application.ScreenUpdating = False
With ActiveSheet
With .Range("N1:N" & .Cells(.Rows.Count, 14).End(xlUp).Row)
.AutoFilter Field:=1, Criteria1:="N"
.Offset(1, 0).Resize(.Rows.Count - 14, .Columns.Count).Interior.Color = 65535
.AutoFilter
End With
End With
Application.ScreenUpdating = True
End Sub
In your code, you are looping through the cells, but you're still changing the color of the initial selection (not of the cell in the loop). Adjust as follows:
Sub highlight_new_pos()
Dim rng As Range, lCount As Long, LastRow As Long
Dim cell As Object
With ActiveSheet 'set this worksheet properly!
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In .Range("N2:N" & LastRow)
If cell = "N" Then
With cell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End if
Next cell
End With
End Sub
If you want the entire row, change cell.Interior to cell.entirerow.Interior

VBA to loop through column if the header is not empty

I want to start looping through each column if the column header is not blank. I don't know how to locate the header of each column as it is letter, not number.
I googled many codes but they are not doing exactly I want.
Below is the code. Any help would be appreciated.
Sub ColorGradient()
'Find the last roll number
Dim Lastrow As Integer
Lastrow = Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim cs As ColorScale
Dim rng As Range
'Loop through each column
For Each rng In Range("B4:AA" & Lastrow).Columns
'Set color gradient
Set cs = rng.FormatConditions.AddColorScale(ColorScaleType:=3)
' Set the color of the lowest value
With cs.ColorScaleCriteria(1)
.Type = xlConditionValueLowestValue
With .FormatColor
.Color = RGB(248, 105, 107)
.TintAndShade = 0
End With
End With
' In the middle
With cs.ColorScaleCriteria(2)
.Type = xlConditionValuePercentile
.Value = 50
With .FormatColor
.Color = RGB(255, 244, 189)
.TintAndShade = 0
End With
End With
' At the highest value
With cs.ColorScaleCriteria(3)
.Type = xlConditionValueHighestValue
With .FormatColor
.Color = RGB(0, 204, 255)
.TintAndShade = 0
End With
End With
Next rng
End Sub
I'm not sure I understand completely, but test that the "header" row value is not blank first, then set your column range and do stuff to it.
Option Explicit
Sub test()
Dim rHdrs As Range
Dim r As Range
Dim rCol As Range
Dim Lastrow As Integer
With ThisWorkbook.Sheets(1)
Lastrow = .Columns(1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set rHdrs = .Range("B3:AA3")
For Each r In rHdrs
If r.Value <> "" Then
Set rCol = .Range(.Cells(4, r.Column), .Cells(Lastrow, r.Column))
'loop through cells in rCol
'do stuff with the non-empty header column ranges here
End If
Next r
End With
End Sub
I assumed you were doing this on Thisworkbook.sheets(1).

How to copy a range and omit blank cells?

In column A on sheet 1 there are 3000 cells that I need copied at 350 cells each. My current Macro is copying everything just fine until I get to the end and it copies blanks. Is there a way to include a "cell is blank do nothing" code into my macros?
Sorry if this sounds uneducated, I'm just starting on learning macro.
Here is a copy of the current macro, the rest of the macro is the same as this just with increasing numbers by 350.
Sub Copy_Bins_1_350()
If Range("D12").Value <> "!" Then
Exit Sub
ElseIf Range("D12").Value = "!" Then
Sheets("sheet1").Select
Range("B2:B351").Select
Selection.Copy
Range("B2").Select
Sheets("sheet2").Select
Range("E12").Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
End If
End Sub
You can use Union to form your own range of non empty cells and then copy them.
Also INTERESTING READ
Try this (TRIED AND TESTED)
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim aCell As Range, rngCopyFrom As Range, rng As Range
Dim lRow As Long
Set wsI = ThisWorkbook.Sheets("BIN LIST PASTE")
Set wsO = ThisWorkbook.Sheets("BIN LIST COPY")
Set rng = wsI.Range("B2:B351")
For Each aCell In rng
If Len(Trim(aCell.Value)) <> 0 Then
If rngCopyFrom Is Nothing Then
Set rngCopyFrom = aCell
Else
Set rngCopyFrom = Union(rngCopyFrom, aCell)
End If
End If
Next
If Not rngCopyFrom Is Nothing Then _
rngCopyFrom.Copy wsO.Range("E12")
With wsO
lRow = .Range("E" & .Rows.Count).End(xlUp).Row
Set rng = .Range("E12:E" & lRow)
With rng.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
End With
End Sub

VBA Delete Empty Cells with Multiple Column Selection

I am having a small amount of trouble with finding a possible solution to a potential problem of mine. I am writing a macro for my supervisor using VBA so that she can just click a button assigned to this macro and follow the directions and get the data she needs. The issue I'm running into is when the macro pastes the data, it has trouble deleting empty cells if the user selects multiple columns.
Sub DataPull()
' Written by Agony
' Data Pull macro
Dim rng1 As Range
Dim rng2 As Range
Dim chc1
Dim chc2
Dim wb1 As Workbook
Dim wb2 As Workbook
'Choose file to get data
chc1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file to pull data from")
If chc1 = False Then Exit Sub
'Choose file to paste data
chc2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file to paste data to")
If chc2 = False Then Exit Sub
'Open first file and copy range
Set wb1 = Workbooks.Open(chc1)
Set rng1 = Application.InputBox("Select cells to transfer", "Selection", "Use your mouse/pointer to select the cells", Type:=8)
rng1.Copy
wb1.Close SaveChanges:=False
'Open second file and paste with specs
Set wb2 = Workbooks.Open(chc2)
Set rng2 = Range("A1")
rng2.PasteSpecial
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Name = "Cambria"
.Size = 12
.TintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'Loop to delete empty cells
Dim i As Long
Dim rows As Long
Dim rng3 As Range
Set rng3 = ActiveSheet.Range("A1:Z50")
rows = rng3.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(rng3.rows(i)) = 0 Then rng3.rows(i).Delete
Next
wb2.Activate
MsgBox ("Macro Complete")
End Sub
As above shows, the range is currently tentative. I would like the function to delete cells that are empty if the user selects a range with multiple columns. I've tried using Len for the cells, but that doesn't seem to work either. Any help is greatly appreciated. Thanks!
I don't think you can use the .Copy and .Paste when the source workbook is closed.
I think that whatever you're copying gets lost when the workbook is closed.
So a possible solution to your problem would be to close the wb1 at the end of your macro and not immediately after the copy command.
So move wb1.Close SaveChanges:=False to after this block
...
'Open second file and paste with specs
Set wb2 = Workbooks.Open(chc2)
Set rng2 = Range("A1")
rng2.PasteSpecial
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Name = "Cambria"
.Size = 12
.TintAndShade = 0
End With
wb1.Close SaveChanges:=False ' moved it here
...
Deletetion
Try this sub see if this is what you want. What this does it finds the last column used in spreadsheet and last row in each column. Iterates back from the last row in each column and deletes all empty cells shifting the filled cells up.
Sub DeleteAllAtOnce()
Application.ScreenUpdating = False
Dim lastColumn As Long
Dim lastRow As Long
lastColumn = ActiveSheet.UsedRange.Columns.Count
Dim i As Long, j As Long
Dim cell As Range
For i = lastColumn To 1 Step -1
lastRow = Cells(rows.Count, i).End(xlUp).Row
For j = lastRow To 1 Step -1
Set cell = Cells(j, i)
If IsEmpty(cell) Then cell.Delete shift:=xlUp
Next j
Next i
Application.ScreenUpdating = True
End Sub