I am trying to write the VBA Code for checking if the formula exists in a range of cells. Below is my query which is somehow not working(The cells with formulas are not turning red). Can anyone please help me out.
Sub Test()
Dim LResponse As Integer
Set rr = Application.InputBox( _
prompt:="Select a range On this worksheet", _
Type:=8)
If rr.HasFormula = TRUE Then
rr.Interior.Color = vbRed
End If
End Sub
Edit: I tried looping too
Sub Test()
Set rr = Application.InputBox( _
prompt:="Select a range On this worksheet", _
Type:=8)
For Each cell In Range(rr)
If cell.HasFormula = TRUE Then
cell.Interior.Color = vbRed
End If
Next
End Sub
From the Range.HasFormula docs:
True if all cells in the range contain formulas; False if none of the cells in the range contains a formula; null otherwise.
Its return value is determined by all the cells having or not having formulas. If only some have formulas, then it is null.
To fix your issue, use a loop over each individual cell:
Dim rng as Range
For Each rng in rr
If rng.HasFormula Then
rng.Interior.Color = vbRed
End If
Next
EDIT: In your loop attempt, drop the Range call:
For Each cell in rr
EDIT 2: You can also use Range.SpecialCells:
On Error Resume Next '<~ an error will occur if there are no formula cells
Dim rng as Range
Set rng = rr.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng Is Nothing Then
rng.Interior.Color = vbRed
End If
Related
Is there a function to get the activecell formatting? e.g. background color, font, font color, cell border, font size etc.
I want to update the format of an entire worksheet based on a formatted cell before action (i.e. the format I want to change) by another formatted cell (i.e. the format I want to apply).
Sub Rep_all_format()
Dim fmt_bef As CellFormat
Dim fmt_aft As CellFormat
Dim rngReplace As Boolean
Dim msg As String
Dim Sh As Worksheet
Dim Rg As Range
Dim ppos1 As Range
Dim ppos2 As Range
Dim Find As String
Dim Remplace As String
Set ppos1 = Application.InputBox(Prompt:="Select the cell format you wanna change", Title:="Remplace", Default:=ActiveCell.Address, Type:=8)
Set ppos2 = Application.InputBox(Prompt:="Select the cell format you wanna apply", Title:="Select", Type:=8)
Find = ppos1.FormatConditions 'this is theorical I do not know the function
Remplace = ppos2.FormatConditions 'this is theorical I do not know the function
Application.ScreenUpdating = False
Set fmt_bef = Application.FindFormat
Set fmt_aft = Application.ReplaceFormat
For Each Sh In ThisWorkbook.Worksheets
Set Rg = Sh.UsedRange
With fmt_bef
.Clear
.FormatConditions = Find
End With
With fmt_aft
.Clear
.FormatConditions = Remplace
End With
Rg.Replace What:="", Replacement:="", _
SearchFormat:=True, ReplaceFormat:=True
Next
fmt_bef.Clear
fmt_aft.Clear
Application.ScreenUpdating = True
MsgBox ("The desired format has been applied through all the workbook")
End Sub
Assuming, from the code that you have provided, that your cell has been formatted using Conditional Formatting, you need to access is the Range.DisplayFormat property.
Note that I showed only some of the formatting options for a cell. There is documentation online for other formatting options (eg other borders, numberformat, etc) but this should get you started.
For example:
Option Explicit
Sub foo()
Dim R As Range, C As Range
Dim fc As FormatCondition
Set R = Range(Cells(1, 1), Cells(5, 1))
For Each C In R
With C.DisplayFormat
Debug.Print .Interior.Color
Debug.Print .Font.Name
Debug.Print .Font.Color
Debug.Print .Borders(xlEdgeLeft).LineStyle ' etc
Debug.Print .Font.Size
End With
Stop
Next C
End Sub
If the cell has been formatted manually, or directly using code, then just access the various properties directly, not using the DisplayFormat property eg:
For Each C In R
With C
Debug.Print .Interior.Color
Debug.Print .Font.Name
Debug.Print .Font.Color
Debug.Print .Borders(xlEdgeLeft).LineStyle ' etc
Debug.Print .Font.Size
End With
Stop
Next C
What you are looking for are the Range.Interior and Range.Font properties etc.
You can see some examples in the links below:
https://learn.microsoft.com/en-us/office/vba/api/excel.font(object)
https://learn.microsoft.com/en-us/office/vba/api/excel.interior(object)
https://learn.microsoft.com/en-us/office/vba/api/excel.border(object)
I have written a short Macro to change cells of a given colour to another colour in a workbook. This code throws no errors however it simply does nothing.
I have already tested the colour codes to see if they are correct using MsgBox ActiveCell.DisplayFormat.Interior.color
Option Explicit
Sub Recolour()
Application.ScreenUpdating = False
Dim Sheet As Worksheet
Dim Rng As Range
Dim OldColour As Variant
Dim NewColour As Variant
Dim Cell As Range
Set Rng = ActiveSheet.Range("A1:Y457")
OldColour = 128
NewColour = RGB(134, 38, 51)
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If ActiveCell.DisplayFormat.Interior.Color = OldColour _
Then _
Set ActiveCell.DisplayFormat.Interior.Color = NewColour _
Else
Next Cell
Next Sheet
Application.ScreenUpdating = True
End Sub
This is probably something simple and daft however I need to ask.
DisplayFormat is read-only. If you want to change the property, you need to drop DisplayFormat. Also, if you are using For each Cell, then you should refer to Cell, not ActiveCell.
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If Cell.Interior.color = OldColour Then
Cell.Interior.color = NewColour
End if
Next Cell
Next Sheet
You only need to Set object variables in VBA, your if statement is also problematic. Try:
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If ActiveCell.DisplayFormat.Interior.color = OldColour Then
ActiveCell.DisplayFormat.Interior.color = NewColour
End if
Next Cell
Next Sheet
I'm trying to create a VBA Macro that would search for a non-blank cell in "Sheet1" and if non-blank, it would paste the respective active cell column from "Sheet1" to the same column in "Sheet2".
Below is my code, but I'm sure I'm doing something wrong, because the code is throwing me an error : 1004.
Sub Test()
Dim cel As Range
Dim strAddress As String
Dim StartPoint As Range
Set StartPoint = ActiveCell
'Change to necessary amount of Rows & Columns
With Sheets("Sheet1").Range(Cells(9, 5), Cells(1000, 200))
Set cel = .Find(What:="*", After:=Cells(1000, 200), SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not cel Is Nothing Then
strAddress = cel.Address
Do
' Do something with cel, e.g.
StartPoint.EntireColumn.Copy Destination:=Worksheets("Sheet2").Range(StartPoint.Column & "1").End(xlToRight).Offset(1)
Set cel = .FindNext(After:=cel)
If cel Is Nothing Then Exit Do
Loop Until cel.Address = strAddress
End If
End With
End Sub
Can someone kindly advise what I'm doing wrong?
Thank you!
Try these two modifications:
With Sheets("Sheet1").Range("E9:GR1000")
.
cel.EntireColumn.Copy Worksheets("Sheet2").Columns(cel.Column)
I have a spreadsheet that is generated as a report in our Enterprise system and downloaded into an Excel spreadsheet. Blank cells in the resulting spreadsheet are not really blank, even though no data is present - and the blank cells do Not contain a 'space' character.
For example, the following cell formula in A2 returns TRUE (if A1 is a blank cell):
=IF(A1="","TRUE","FALSE")
However,
=ISBLANK(A1)
returns FALSE.
You can replicate this problem by typing an apostrophe (') in a cell and copying the cell. Then, use Paste Special...Values to paste to another cell and the apostrophe is not visible in the pasted cell, nor in the Formula Bar. There appears to be a clear cell, but it will evaluate to FALSE using ISBLANK.
This causes sorting to result in the fake blank cells at the top of an ascending sort, when they need to be at the bottom of the sort.
I can use a vba loop to fix the fake blanks, to loop through every column and evaluate
IF Cell.VALUE = "" Then
Cell.Clear
but because the spreadsheet has tens of thousands of rows of data and as many as 50 columns, this adds substantial overhead to the program and I would prefer to use FIND and Replace.
Here is the code that does not currently work:
Range("ZZ1").Copy
Range("Table1[#All]").Select
With Selection
.Replace What:="", Replacement:=.PasteSpecial(xlPasteValues, xlNone, False, False), _
LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
The following things do not work to clear the fake blank cells either:
Replacement:= vbnullstring
Replacement:= ""
Replacement:= Cells.Clear
Replacement:= Cells.ClearContents
Replacement:= Cells.Value = ""
I have tried 20 other things that do not work either.
Try this
With ActiveSheet.UsedRange
.NumberFormat = "General"
.Value = .Value
End With
A variant array provides an efficient way of handling the false empties:
Sub CullEm()
Dim lngRow As Long
Dim lngCol As Long
Dim X
X = ActiveSheet.UsedRange.Value2
For lngRow = 1 To UBound(X, 1)
For lngCol = 1 To UBound(X, 2)
If Len(X(lngRow, lngCol)) = 0 Then X(lngRow, lngCol) = vbNullString
Next
Next
ActiveSheet.UsedRange.Value2 = X
End Sub
The problem is that you are searching for a hidden .PrefixCharacter which are not covered by the standard replacement function. For more information on this you might want to visit MSDN: https://msdn.microsoft.com/en-us/library/office/ff194949.aspx
In order to find and replace these you'll have to use the .Find function because it can look at the formulas (rather than only at a cell's value). Here is a short sample code to illustrate that:
Option Explicit
Public Sub tmpTest()
Dim cell As Range
Dim rngTest As Range
Dim strFirstAddress As String
Set rngTest = ThisWorkbook.Worksheets(1).Range("A1:G7")
Set cell = rngTest.Find("", LookIn:=xlFormulas, lookat:=xlPart)
If Not cell Is Nothing Then
strFirstAddress = cell.Address
Do
cell.Value = vbNullString
Set cell = rngTest.FindNext(cell)
Loop While strFirstAddress <> cell.Address And Not cell Is Nothing
End If
End Sub
I can't figure out anything that you could put in Replacement to get that to work. I'm afraid you're stuck looping. You can reduce the overhead by using .Find instead of looping through every cell.
Sub ClearBlanks()
Dim rng As Range
Dim rFound As Range
Dim sFirstAdd As String
Dim rFoundAll As Range
Set rng = Sheet1.UsedRange
Set rFound = rng.Find(vbNullString, , xlValues, xlWhole)
If Not rFound Is Nothing Then
sFirstAdd = rFound.Address
Do
If rFoundAll Is Nothing Then
Set rFoundAll = rFound
Else
Set rFoundAll = Application.Union(rFound, rFoundAll)
End If
Set rFound = rng.FindNext(rFound)
Loop Until rFound.Address = sFirstAdd
End If
If Not rFoundAll Is Nothing Then
rFoundAll.ClearContents
End If
End Sub
You can use the table filter to select the (seemingly) blank cells in each column and clear the contents. This should be quicker than finding each blank cell.
Sub clearBlankTableEntries()
Dim tbl As ListObject, c As Byte
Set tbl = ActiveSheet.ListObjects("testTable")
For c = 1 To tbl.Range.Columns.Count
tbl.Range.AutoFilter Field:=c, Criteria1:="="
Range(tbl.Name & "[Column" & c & "]").ClearContents
tbl.Range.AutoFilter Field:=c
Next c
End Sub
Is there any way to remove error message(object required message) that pops out from the input box whenever the user presses the cancel button?
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
'to remove 0 values that may be a result of a formula or direct entry.
Set inp = Selection
inp.Interior.ColorIndex = 37
Set rng = Application.InputBox("Copy to", Type:=8)
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then cell.Clear
Next
End Sub
Not quite sure why you are using the inputbox, you don't even use it in the code.
This should take care of the errors.
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
'to remove 0 values that may be a result of a formula or direct entry.
Set rng = Nothing
Set inp = Selection
inp.Interior.ColorIndex = 37
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled...", vbInformation
Exit Sub
Else
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
End If
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then cell.Clear
Next
Application.CutCopyMode = 0
End Sub
That is not a InputBox error. That is your wrong usage. In your code, you immediately set value from InputBox return. That may cause error because of setting empty value("") to an Range object.
So, you need to modify as follow:
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
Dim inputRange As String
'to remove 0 values that may be a result of a formula or direct entry.
Set inp = Selection
inp.Interior.ColorIndex = 37
inputRange = Application.InputBox("Copy to")
If Not IsEmpty(inputRange) Then
Set rng = Range(inputRange)
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then
cell.Clear
End If
Next
End If
End Sub
Not tested. Suggestion for you. If it is not work, let me know.