I am currently using this basic code to divide the value of a cell by 1000:
Sub Divide_by_1000()
Dim cell As Range
For Each cell In Selection
cell = cell / 1000
Next
End Sub
Whilst it works very well for hard-coded numbers, if used on a cell with a formula in it, it removes the formula and outputs a number.
Ideally, I would like the macro to work as it does for a cell with a number in it, but for a cell with a formula I would like it to wrap brackets around the current formula and put a /1000 at the end (i.e. keeping the formula in tact)
I believe there will need to be a test to check if the cell has a formula in it first and apply the code I already have if it doesn't and the code I outlined above if it does.
Any help would be much appreciated.
You can check if the cell has a formula by checking if the first character is a equal sign =
If Left$(cell.Formula, 1) = "=" Then
or even better
If cell.HasFormula Then
and then rewrite the formula extended by ( … )/1000
cell.Formula = "=(" & Right$(cell.Formula, Len(cell.Formula) - 1) & ")/1000"
also I recommend to check if the cell.Value is a number before you divide by 1000
ElseIf IsNumeric(cell.Value) Then
cell.Value = cell.Value / 1000
So you end up with something like
If Left$(cell.Formula, 1) = "=" Then
cell.Formula = "=(" & Right$(cell.Formula, Len(cell.Formula) - 1) & ")/1000"
ElseIf IsNumeric(cell.Value) Then
cell.Value = cell.Value / 1000
End If
Note while this will work for normal formulas, it will crush eg array formulas.
After comments with #PEH:
You can use .HasFormula and .HasArray to test for the formula type
If cell.HasFormula Then
If cell.HasArray Then
cell.Offset(0, 1).FormulaArray = "=(" & Right$(cell.FormulaArray, Len(cell.FormulaArray) - 1) & ")/1000"
Else
cell.Offset(0, 1).Formula = "=(" & Right$(cell.Formula, Len(cell.Formula) - 1) & ")/1000"
End If
ElseIf IsNumeric(cell.Value2) Then
cell.Offset(0, 1).Value2 = cell.Value2 / 1000
End If
A range/cell can be checked for formulas using the HasFormula property e.g.
Dim TheArea as range
Set TheArea = range("some name")
If TheArea.HasFormula then
' All the cells in the range have a formula
End if
alternatively you could use the specialcells property of a range e.g.
For Each Cell In TheArea.SpecialCells(xlCellTypeConstants)
Cell.Value = cell.Value/1000
Next Cell
For Each Cell In TheArea.SpecialCells(xlCellTypeFormulas)
Cell.Formula = "=(" & Right$(Cell.Formula, Len(Cell.Formula) - 1) & ")/1000"
Next Cell
This approach also gives you the opportunity to detect other possible scenarios e.g. xlCellTypeBlanks if they are important to you. The full list of special cells can be found here ...
https://learn.microsoft.com/en-us/office/vba/api/excel.range.specialcells
Related
I am trying to divide all the cells in a selection by 1000 but not cells which have a sum formula.
Criteria:
Cell must have a number.
Cell should not contain the Sum() formula (any other formula is okay).
If both of these criteria are met then divide the cell value by 1000.
For Each cell In Selection.Cells
If IsNumeric(cell) = False Or cell.Address = Left(ActiveCell.Formula, 5) = "=Sum(" Or cell.Address = Left(ActiveCell.Formula, 6) = "=+SUM(" Or cell.Address = Left(ActiveCell.Formula, 6) = "=-SUM(" Then
MsgBox ("Selection either does contain numbers or has only sum formulae")
Else
cell.value = cell.value / 1000
End If
Next
Not sure what you're trying to achieve with
Cell.Address = Left(ActiveCell.Formula,5) = "=Sum(
You can only compare one value with another.
I'm sure the more advanced people here will frown on the way I phrased the if statement but it does the job:
Sub divideBy1000()
Dim formCheck As Variant
For Each ccell In Selection.Cells
Debug.Print (ccell.Formula)
Debug.Print (ccell.Value)
formCheck = InStr(ccell.Formula, "SUM(") 'This checks if SUM is in the formula and returns a value bigger than 0 if so (where it occurs in the string).
If len(trim(ccell.value2))>0 Then
If IsNumeric(ccell.Value) And (formCheck = Null Or formCheck = 0) Then
'You have to use AND so none of the SUM formulas get through, no else needed this way
If Left$(ccell.Formula, 1) = "=" Then 'EDIT to keep your formula
ccell.Formula = "=(" & Right$(ccell.Formula, Len(ccell.Formula) - 1) & ")/1000"
Else
ccell.Value = ccell.Value / 1000
End If
End If
End If
Next ccell
End Sub
Edit:
Added a catch for empty cells so they don't turn to 0 and added Instr to check for the SUM as suggested by #Marcucciboy2
I am very new to Excel, VBA, Macro. My macro was working fine because I gave a simple formula, for example, D2(column name)-C2(column name) = Total time in HH:MM format new column. But I notice for some output is just #### not sure what is wrong. 1).Column)).Formula = _
"=" & cl.Offset(1, 0).Address(0, 0) & "-" & .Cells(2, col1).Address(0, 0)
cl.Offset(, 1).EntireColumn.NumberFormat = "[hh]:mm"
The issue occurs because your date in J is earier than in I and therefore the result is negative. You can use the ABS() function to get the absolute difference as positive value.
Therefore adjust your formula as below:
.Formula = "=ABS(" & cl.Offset(1, 0).Address(0, 0) & "-" & .Cells(2, col1).Address(0, 0) & ")"
You have an incorrect formula in this line:
.Range(cl.Offset(1, 1), .Cells(lastR, cl.Offset(1, 1).Column)).Formula = _
"=" & cl.Offset(1, 0).Address(0, 0) & "-" & .Cells(**2**, col1).Address(0, 0)
Why .Cells(2, col1)? This is always giving you row2 of column 1.
Also, after this line:
If cl.Value = "Full Out Gate at Inland or Interim Point (Destination)_recvd"
Then
Add:
If cl.Offset(0,1).Value = "Response Time" Then Exit For
This will keep you from inserting a new column every time you run the macro.
Try using clear variable names and consistent method for referring to rows and columns.
actCol = col1
recvdCol = cl.Column
responseCol = cl.offset(0,1).Column
.Range(lastR, responseCol).Formula = _
"= Abs(" & .Cells(lastR, recvdCol) & "-" & .Cells(lastR, actCol).Address(0, 0) & ")"
I would use a simpler approach. Highlight the entire table, and click "Format as Table", and be sure to check off "My table has headers." This will give you a named range (default name is Table1, but you can change it). Then, in the Response Time column, simply enter your formula on the first row of the table, but use your mouse to select the cells instead of typing in a cell name like "I2". You will find that the resulting formula includes something like =[#actl]-[#recvd], except that the actl and recvd will be replaced by your actual column names. And, the formula will apply to every row of the table. If you add a new row, the formula will automatically appear in that row. No code needed.
If you have a reason to use code instead of a Table (named ranges), then I would recommend (1) this code be placed directly in the "Main" worksheet module and (2) use use the "Worksheet_Changed" procedure. Microsoft Excel VBA Reference. In this case, any time the
Private Sub Worksheet_Change(ByVal Target As Range)
'Note, Target is the Range of the cell(s) that just changed.
If Intersect(Target, Range("A1:A10")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
If ActiveSheet.Cells(1, Target.Column) = "Full Out Gate at Inland or Interim Point (Destination)_actual" Then
' Cell in actual column was modified. Let's set the formula in the Response Time column:
On Error Goto EH
Application.EnableEvents = False
' Add your code here. You'll need to modify it somewhat to accommodate this methodology.
Application.EnableEvents = True
End If
EH:
Application.EnableEvents = True
Err.Raise ' expand this to whatever error you wish to raise
End Sub
Err.Raise help
I'm working on a 'dashboard' in excel where the user can select a commodity and then presses the run button, so the code then prints out all suppliers linked to that commodity. (Several commodities and supplier names are listed on other tabs in the same workbook, and the code goes over all tabs to collect the right supplier names)
EDIT: the issue is due to a supplier name being longer than 255 characters.
The debugger focuses on this code in particular:
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
cell.Offset(0, 0).Font.Color = vbRed
End If
This code is part of the bigger set below. The code highlights all suppliernames that are listed under the chosen category in different tabs (hence they would be printed out multiple times, I want to highlight the duplicate values).
'##### Find duplicates in commodity column and highlight them ######
Dim myDataRng As Range
Dim cell As Range
Set myDataRng = Range("E10:E" & Cells(Rows.Count, "E").End(xlUp).Row)
For Each cell In myDataRng
cell.Offset(0, 0).Font.Color = vbBlack
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
cell.Offset(0, 0).Font.Color = vbRed
End If
Next cell
Any idea what it could be?
The error is not immediately obvious. I made a few tweaks to the code, however this should allow you to see what's being evaluated. Typically you'd get this error from the formula not being entered with the correct format, but it works on my end.
I removed the Offset(0,0) as it is superfluous at present with no offset applied, as well as placing the vbBlack formatting in an Else block for performance/clarity.
However seeing the Debug.Print statement should be critical for understanding when the code is not functioning. The only other thought I have, is you may want to clarify which sheet this Countif is being completed on.
Update
I've revised my answer to use SumProduct instead of CountIf to workaround the issue of 255 characters being the limit for CountIf.
Public Sub TestSub()
Dim myDataRng As Range
Dim cell As Range
Dim EvalStr As String
Set myDataRng = Range("E10:E" & Cells(Rows.Count, "E").End(xlUp).Row)
For Each cell In myDataRng
EvalStr = "SumProduct((" & myDataRng.Address & "=" & cell.Address & ")+0)"
If Application.Evaluate(EvalStr) > 1 Then
cell.Font.Color = vbRed
Else
cell.Font.Color = vbBlack
End If
Next cell
End Sub
Change your line:
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
With:
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & " > 1 )") Then
For exmaple, I want add formula to all selected cell where I click.
The Cells.Address is good for recognise the cell, but when I add the formula, and I after see the cell, the vba add lock dollars symbol and I want avoid that.
e.g.:
r = Target.Row
Cells(r, 1).Formula = "=" & Cells(r, 2).Address & "*" & Cells(r, 3).Address
Result in cell (if the target A1): =$A$2 * $A$3
But I want that result: =A2 * A3
Set the first two criteria of the .Address to 0:
Cells(r, 1).Formula = "=" & Cells(r, 2).Address(0,0) & "*" & Cells(r, 3).Address(0,0)
You have to set both the row-absolute and the column-absolute to false.
https://msdn.microsoft.com/en-us/library/office/ff837625.aspx shows in more detail.
I'm new to VBA so I got a problem trying to convert some string number to a value number for a IF validation.
The problem is. I have Column "A" filled with something like this:
E/B: Houses 01
E/B: Houses 02
E/B: Building/New Villa
E/B: Building/Bella Casa
E/B: Houses 03
So, in my code, I want it to fill the "B" Column with the last 2 numbers if there's numbers or the name if there isn't.
Set Rng = Range("A8:A" & Range("I" & Rows.Count).End(xlUp).Row)
For Each celula In Rng.SpecialCells(xlCellTypeVisible)
Select Case True
Case IsNumeric(Right(celula, 2)) = True
celula.Offset(0, 1).Value = Right((celula), 3)
Case Else
celula.Offset(0, 1).Value = Mid(celula, InStr(4, celula, "/") + 1, Len(celula))
End Select
Next celula
But the Case IsNumeric(Right(celula, 2)) = True is never True. It do not capture the 2 last numbers. But it works alright with the names and returns "New Villa" and "Bella Casa". And I think the problem is that Right(celula, 2) is never a number, even if theres a number.
I want to know if theres a way to convert "Right(celula, 2)" in a Value, just like the =Value formula in excel, to do the validation.
OBS: Before trying this way, I had a excel formula applied to those cells and it worked, but I want to try this way for learning purposes.
Thanks
I think the for each loop itself works as expected.
However, this
Set Rng = Range("A8:A" & Range("I" & Rows.Count).End(xlUp).Row)
is probably where the problem lies. You have to make sure you've got the correct Range. You can verify by debugging: Debug.print Rng.Address.
Sub t()
Dim rng As Range
With ActiveSheet
Set rng = .Range("a1:a" & .Range("a" & .Rows.Count).End(xlUp).Row)
For Each cell In rng.Cells
If Val(Right(cell.Value, 2)) = 0 Then
cell.Offset(0, 1) = Mid(cell.Value, InStrRev(cell.Value, "/") + 1, Len(cell))
Else
cell.Offset(0, 1) = Val(Right(cell.Value, 2))
End If
Next cell
End With
End Sub