I need a VBA code that clears only cells containing formulas and skip cells containing values in a given Excel Worksheet.
I have the following Code:
Dim rng As Range, cl As Range
Set rng = ThisWorkbook.Sheets("MATRIX").Range("C2:AU10000")
For Each cl In rng
If cl.Hyperlinks = .Hyperlinks Then
cl.ClearContents
End If
Next cl
Try this approach, please:
If cl.HasFormula Then
cl.ClearContents
End If
This should be the quickest way
rng.SpecialCells(xlCellTypeFormulas).ClearContents
HasFormula vs SpecialCells(xlTypeCellTypeFormulas)
Option Explicit
Sub RemoveHasFormula()
Dim rng As Range, cl As Range
Set rng = ThisWorkbook.Sheets("MATRIX").Range("C2:AU10000")
For Each cl In rng
If cl.HasFormula Then cl.ClearContents
Next cl
End Sub
Sub RemoveSpecialCells()
Dim rng As Range
Set rng = ThisWorkbook.Sheets("MATRIX").Range("C2:AU10000")
rng.SpecialCells(xlCellTypeFormulas).ClearContents
End Sub
Delete formulae via a range's XML structure
For the sake of the art and in order to complete the above solutions I demonstrate a rather unknown approach using a range's xml spreadsheet value (so called ".Value(11)"):
Option Explicit
Sub ExampleCall()
Dim rng As Range: Set rng = Sheet1.Range("a11:b14")
'a) Get range data as xml spreadsheet value
Dim s As String: s = rng.value(xlRangeValueXMLSpreadsheet) ' //or: s = rng.Value(11)
'b) delete formulae and write data back to range
ClearFormulae s ' call sub changing s (By Reference)
rng.value(xlRangeValueXMLSpreadsheet) = s
End Sub
Sub ClearFormulae(s)
'Purpose: delete formulae in xlRangeValueXMLSpreadsheet contents of a given range
'Author : https://stackoverflow.com/users/6460297/t-m
'Date : 2020-07-18
'[1]Set xml document to memory
Dim xDoc As Object: Set xDoc = CreateObject("MSXML2.DOMDocument.6.0")
'[2]Add namespaces.
xDoc.SetProperty "SelectionNamespaces", _
"xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet' " & _
"xmlns:ht='http://www.w3.org/TR/REC-html40'"
'[3]Load cells with formulae into xml document.
If xDoc.LoadXML(s) Then ' load wellformed string content
Dim cell As Object, cells As Object
Set cells = xDoc.SelectNodes("//ss:Cell[#ss:Formula]") ' XPath using namespace prefixes
For Each cell In cells
cell.RemoveAttribute ("ss:Formula")
cell.SelectSingleNode("ss:Data/#ss:Type").Text = "String"
cell.SelectSingleNode("ss:Data").Text = ""
Next cell
'[4] return xml as string content
s = xDoc.XML
End If
End Sub
Further hint to Example call
Instead of replacing the same range, you can also copy the whole data set (including formats) to another sheet via:
Sheet2.Range("D2").Resize(rng.Rows.Count, rng.Columns.Count).value(11) = s
Caveat
As #ChrisNeilson pointed out,
"this can also gives unexpected results in some circumstances
where the range being processed by ClearFormulae includes some cells
that contain formula referring to cells outside the range being processed".
Testing Value(11) against other solutions
Testing with a 20% formula rate (in a double column range) shows that the SpecialCells approach (posted by #Storax and #VBasic2008) starts extremely fast, but looses against my Value(11) approach as soon as the data range exceeds ~ 115,100 rows.
The HasFormula solution (#FaneDuru) seems to be restricted to smaller ranges getting soon time consuming at ranges over 10000 rows.
Related
I am trying to cycle through multiple sheets in a work book and replace the formulas with values.
I would like to retain any formatting in the cells though (e.g. when I run this, it will not only change 3% to .03, but preserve any formatting)
Thank you!
Below is my code:
Sub copypastfa()
Dim count As Integer
For count = 1 To 9
Dim rng As Range
Set rng = Worksheets(1).Range("A1:Z101")
ActiveSheet.Range("A1").Resize(rng.Rows.count, rng.Columns.count).Cells.Value = rng.Cells.Value
Worksheets(ActiveSheet.Index + 1).Select
Next count
End Sub
Two unconvential approaches (other than copying)
As you found out yourself, assigning (datafield) arrays to target ranges transport only values.
[0) The conventional way]
A familiar way to solve the asked requirement to include all formats would consist in subsequent copying/pasting formats as well as values as follows:
Sub TheConventionalWay()
'0) get worksheets collection
Dim w As Sheets ' use the wider declaration type here and
Set w = ThisWorkbook.Worksheets ' assign only worksheets to the sheets collection
'1) define source range
Dim rng As Range
Set rng = w(1).Range("A1:Z101")
'2) Copy-Paste
rng.Copy
Dim i As Long
For i = 1 to 9
With Worksheets(i).Range(rng.Address)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
Next
End Sub
... but I would also like to demonstrate two not so well-known quick approaches here:
Approach 1) via xlRangeValueXMLSpreadsheet
This approach allows to get the complete spreadsheet info in an XML string which can be reassigned to the size identical target ranges. Furthermore it needs no double-assignements.
Sub XMLSpreadsheetApproach()
'0) get worksheets collection
Dim w As Sheets ' use the wider declaration type here and
Set w = ThisWorkbook.Worksheets ' assign only worksheets to the sheets collection
'1) define source range
Dim rng As Range
Set rng = w(1).Range("A1:Z101")
rng.Value2 = rng.Value2 ' change formulae to values
'2) Get Value(xlRangeValueXMLSpreadsheet), aka Value(11)
Dim Val11 as string: Val11 = rng.Value(11)
'3) Pass full XML Spreadsheet info to following worksheets
Dim i As Long
For i = 2 to 9 ' suffices to start at 2
Worksheets(i).Range(rng.Address).Value(11) = Val11 ' xlRangeValueXMLSpreadsheet = 11
Next
End Sub
Syntax
Range.Value (RangeValueDataType)
where RangeValueDataType xlRangeValueXMLSpreadsheet - equalling 11 - returns the values, formatting, formulas, and names of the specified Range object in the XML Spreadsheet format.
Approach 2) via FillAcrossSheets method
The widely unknown FillAcrossSheets method copies a range to the same area on all other worksheets in a collection.
Syntax
.FillAcrossSheets (Range, Type)
where Type (i.e. the XlFillWith enumeration) distinguishes between
-4104 .. xlFillWithAll copies contents and formats.
2 ........... xlFillWithContents copies contents only.
-4122 .. xlFillWithFormats copies formats only.
Sub FillAcrossSheetsApproach()
'0) get worksheets collection
Dim w As Sheets ' use the wider declaration type here and
Set w = ThisWorkbook.Worksheets ' assign only worksheets to the sheets collection
'1) define source range
Dim rng As Range
Set rng = w(1).Range("A1:Z101")
rng.Value2 = rng.Value2 ' change formulae to values
'2) apply to ALL sheets
w.FillAcrossSheets rng, xlFillWithAll
End Sub
If, however you want to include only a series of sheets, include the help function GetWNames() below and replace section 2) by:
'2a) apply ONLY to sheets 1 to 9 ' source sheet has to be included!
ThisWorkbook.Sheets(GetWNames(w,1,9)).FillAcrossSheets rng, xlFillWithAll
Function GetWNames(w As Sheets, first As Long, last As Long)
Dim tmp() As String: ReDim tmp(first To last)
Dim i As Long
For i = first To last
tmp(i) = w(i).Name
Next i
GetWNames = tmp ' return Array(w(1).Name, .. w(last).Name)
'Debug.Print Join(GetWNames, "|")
End Function
Further link
In an older post I demonstrated how to write an array as identical information to all sheets using this method.
I'm concatenating using an excel range:
Set rng = Range("A1:A8")
If one of the cells withing the range is empty it adds a single space.
How do you stop this space from being added?
Assuming you have got constants in those non-empty cells:
Set rng = Range("A1:A8").SpecialCells(2)
Unfortunately, non-contiguous ranges make that we can't put rng into an array or use it in a Join operation. You'll have to loop each cell in the range.
However, I would utilize Application.Trim instead of setting a range. This way we can work through memory (array) instead of a more sluggish Range object reference:
Sub Test()
Dim arr As Variant: arr = [TRANSPOSE(A1:A8)]
Debug.Print Application.Trim(Join(arr, " "))
End Sub
Or, if you don't want to utilize .Evaluate:
Sub Test()
Dim arr As Variant: arr = Range("A1:A8")
With Application
Debug.Print .Trim(Join(.Transpose(.Index(arr, 0, 1)), " "))
End With
End Sub
Note-1: We need Transpose to return a 1D-array to be able to use in Join.
Note-2: If one has got access to TEXTJOIN function, there is no need for all this, but you can utilize that function in an array form.
If you are concatenating range then a simple loop may help:
Dim rng As range, cell As range
For Each cell In range("A1:A8") ' looking through the desired range
If Not cell = "" Then ' if the cell is not empty we have to add it to range
If Not rng Is Nothing Then ' if the range already has some cells in it
Set rng = Union(rng, cell) ' we have to add the cell to an existing range
Else ' if the range does not yet exists
Set rng = cell ' create it and add the first cell
End If
End If
Next
Im trying to make a VBA in excel that changes the content of a cell based on the text in the cells. All the cells I want to change contains a structure of "< (space) 0.005" the number however varies a lot and setting up all the different numbers would take too long.
I have a base for an older project but I can't seem to tweak it to the required needs.
Sub FillEmptyBlankCellWithValue()
Dim cell As Range
Dim InputValue As String
On Error Resume Next
InputValue = InputBox("Enter value that will fill empty cells in selection", _
"Fill Empty Cells")
For Each cell In Selection
If IsEmpty(cell) Then
cell.Value = InputValue
End If
Next
End Sub
You're on a right track. But in general I'd avoid using Selection or any other Select operations as they are prone to many errors.
Instead, I'd recommend using active (detected dynamic) range, or let the user define the range. eg.
Option Explicit
Private Sub fill_blanks
Dim ws as Worksheet: Set ws = Sheets("Sheet1") ' set yours
Dim firstcell as String, lastcell as String, fillvalue as String
Dim datarange as Range
firstcell = InputBox("Enter the starting cell of your data range")
lastcell = InputBox("Enter the last cell of your data range")
fillvalue = InputBox("Enter the value to fill blank cells with")
Set datarange = ws.Range(Trim(firstcell) & ":" & Trim(lastcell))
Dim cell as Range
For each cell in datarange
If IsEmpty(cell) Then
cell = fillvalue
End If
Next cell
End Sub
You could also let them define the range inside a pre-defined cells in
the worksheet, or detect the active range with .End(xlUp) for row
and .End(xlToLeft) for column. Up to you really..
Note: This will paste the result as a String (or "Text") as a Cell Format, you also need to change the Range.Format property.
I am working with an excel file which contains the below values with some cell comments.
The below VB code is for copy the values and comments to an array.
Sub commentToArray()
arrayValues = Range("A1:A6").Value
arrayComments = Range("A1:A6").Comment.Text
End Sub
The values array is working fine, but the comments array populating an error message.
Could you please help me to sort this out.
Thanks,
Aneesh
Your code have two errors:
You can't use Comment.Text method for a range of multiple cells.
You cant' use the Comment.Text on a cell that doesn't contains a comment.
This can be a solution for you:
Sub commentToArray()
Dim arrayValues As Variant
Dim ArrayCommnents() As String
Dim myRange, commentsRange, mycell As Range
Dim i As Integer
arrayValues = Range("A1:A6").Value
Set myRange = ActiveSheet.Range("A1:A6")
Set commentsRange = myRange.Cells.SpecialCells(xlCellTypeComments)
arrayLenght = commentsRange.Count
ReDim arrayComments(arrayLenght)
For Each mycell In commentsRange
i = i + 1
arrayComments(i) = mycell.Comment.Text
Debug.Print (arrayComments(i))
Next mycell
End Sub
Explanation:
I use myRange var with the range to evaluate for comments.
Next, I need to determine wich cells contain a comment, this is the purpose of commentsRange var.
I've used the .SpcialCells() method to get only cells with comments.
Then, I get the lenght of the commentsRange with .Count property. I get the number of cells that constain a comment.
Redimension the array of comments is needed.
The For Each loop is to get cell by cell comments in the range of cells with comments. An incremental index i to run the array and you got it.
I have two worksheets, I want to use a value in sheet to_approve to lookup against column A in sheet submitted, then identify the cell reference so I can paste a value in the cell adjacent (column B).
I have used the following to identify the cell reference, but I don't know how to use it in VBA code.
=ADDRESS(MATCH(To_Approve!D19,Submitted!A:A,0),1,4,1,"submitted")
While many functions can be used in VBA using Application.WorksheetFunction.FunctionName ADDRESS is not one of these (MATCH is)
But even it it was available I would still use a Find method as below as it:
gives you the ability to match whole or part strings, case sensitive or not
returns a range object to work with if the value is found
readily handles a no match
you can control the point in the range being search as to where the search starts
multiple matches can be returned with FindNext
something like
Sub GetCell()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("submitted")
Set rng1 = ws.Columns("A").Find(Sheets("To_Approve").[d19], , xlValues, xlWhole)
If Not rng1 Is Nothing Then
MsgBox rng1.Address & " in sheet " & ws.Name
Else
MsgBox "not found", vbCritical
End If
End Sub
This example should give you an idea of how to find a corresponding value on another sheet and place a second value in the the column to the left. When using VBA, it is not necessary to select cells and then paste; you can directly enter a value into a range (cell) object.
Sub TransferValue()
Dim rngSearch As Range
Dim rngFind As Range
Dim dValue As Double
' initialization
Set rngSearch = Worksheets("to_approve").Range("D19")
dValue = Date
' find the match & insert value
Set rngFind = Worksheets("submitted").Columns(1).Find(What:=rngSearch.Value)
If Not rngFind Is Nothing Then
rngFind.Offset(ColumnOffset:=1).Value = dValue
End If
End Sub
(Note: dValue is a placeholder for whatever value you want to enter.)