I have various formulas in a spreadhseet that I need to convert to a different unit of measure.
Some are as simple a value such as 889 and others are a formula such as the below;
=Incision_Point_1x+(Arm_Depth_1-Graphic_Radius)
I'd like to use VBA to quickly take the existing formula / value and convert it to;
=(889/Unit_of_Measure_Multiplier)
=(Incision_Point_1x+(Arm_Depth_1-Graphic_Radius)/Unit_of_Measure_Multiplier)
How can I do this?
I used the following code;
Range("B3") = "=(" & Range("B3") & "/" & "Unit_Of_Measure_Multiplier)"
Which works perfectly when you have a whole number but deletes the formula and replaces it with a value for my second example, which defeats the point.
Additionally, how do I then apply this to a large data range? i.e. apply it to range B3:D100?
Try this code:
Sub test1()
For Each cl In Range("B3:D100")
If cl.HasFormula Then
v = Mid(cl.Formula, 2) 'remove leading =
Else
v = cl.Value
End If
frm = "=(" & v & "/Unit_Of_Measure_Multiplier)"
Debug.Print frm 'check that this is what you want
cl.Formula = frm
Next
End Sub
Please, try the next way:
Sub adaptFormula()
Dim rngFormula As Range, cel As Range
On Error Resume Next 'for the case of no formula in the range...
Set rngFormula = Range("B3:D100").SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If rngFormula Is Nothing Then Exit Sub
For Each cel In rngFormula.cells 'iterate only between cells having a formula
If InStr(cel.Formula, "=(Inc") > 0 Then
cel.Formula = Replace(cel.Formula, "Incision_Point_1x+(Arm_Depth_1-Graphic_Radius)", "889")
End If
Next
End Sub
Please, check if "Incision_Point_1x+(Arm_Depth_1-Graphic_Radius)" as you show us, is not "Incision_Point_1x + (Arm_Depth_1-Graphic_Radius" (spaces in front and after "+"), as it looks to me more probably. If so, please adapt the string to be replaced according to your real formula string...
Related
I'm wondering if someone can explain how property range.formula works in more detail then vba basic help.
I would like to use this property to test if all cells are empty in range. (I know and I can type a plenty of other codes how to test it but I would like to find way how to do using this property).
So for example if I want to check all cell in range("A1:A10") I've only done it like this.
Private Sub cell_in_range()
Dim i As Integer
Dim iTest As Integer
i = 1
Do While i <= 10 And iTest = 0
iTest = VBA.Len(Sheet17.Range("A" & i).Formula)
If iTest > 0 Then
Call VBA.MsgBox("Not all cells empty")
End If
i = i + 1
Loop
If VBA.Len(shee17.Range("A" & i)) = 0 Then
Call VBA.MsgBox("All cells empty")
End If
End Sub
This works but what if I would like to check in this way for example range of cells range("A1:X1000")
Again I know that instead of range I can you nested do while loops and change cells index like cells(i,j)
but again I would like to do it using property range.formula
I spent an hours to google how to define formula for two dimensional array. Can anybody explain this topic in more detail.
Thanks,
Is this of any help ??
Sub formulatest()
Dim r As Range, rng As Range
Set rng = Range("A1:X1000")
For Each r In rng
If r.HasFormula Then
MsgBox "cell " & r.Address & " has a formula"
Exit Sub
End If
Next r
MsgBox "no cells have formulas"
End Sub
EDIT#1:
You don't need loops. For the range A1:B2:
Sub dural()
Dim rng As Range
Set rng = Range("A1:B2")
arr = rng.Formula
For Each a In arr
MsgBox a
Next a
End Sub
the .formula property is used to set or return the formula contained in a specific range. if the range contains multiple cells the property returns a bidimensional array.
I would use the following instruction
Application.Count(Range("A1:X1000"))
if it returns 0, all cells are empty.
I have an excel sheet where I am doing a VlookUP using VBA. The problem is that I extract information, and the amount is always different. I want to find a way to add to the code that will add information until there is no more information to add.
Here is the code that works but only for the cells I put in:
Sub vLook()
With ThisWorkbook.Worksheets("EODComponents").Range("f5:F200")
.Formula = "=VLOOKUP(C5,($H$5:$i$34),2,FALSE)"
.Value = .Value
End With
End Sub
You can set a lastRow:
Sub vLook()
Dim lastRow as Long
With ThisWorkbook.Worksheets("EODComponents")
lastRow = .Cells(.Rows.Count,6).End(xlUp).Row
With .Range("f5:F" & lastRow)
.Formula = "=VLOOKUP(C5,($H$5:$i$34),2,FALSE)"
.Value = .Value
End With
End With
End Sub
Maybe you can try to use a Do while-loop?
If you put the while statement right, this will continue until the statement becomes false, in your case; there is no more information to add.
You can use the Len()-function to check the length of the text/value inside a cell, when this is zero you can assume the cell is empty.
More information about this item can be found here.
Example:
Public Sub Something()
Dim i As Integer
i = 1
Do While (Len(Cells(i, 1).Text) > 0)
i = i + 1
Loop
MsgBox "The next row of column 'A' is empty: A" & i
End Sub
Hope this helps.
I'm having troubles with a VBA code: There's an Excel sheet (Sheet1) that contains two essential columns (last & first name)
What I am trying to do is, that whenever you add another last and first name to the list, both of them automatically get concatenated in another sheet and form a new list (start position for that list is Sheet11.Range("AB3"), on position AB2 is the list title "Clients").
My code therefore was entered in Sheet1:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tmp As Range
For Each tmp In Sheet1.Range("C4:C100")
If tmp.Value <> "" And tmp.Offset(0, 1).Value <> "" Then
Sheet11.Cells(Cells(Rows.Count, "AB").End(xlUp).Row + 1, "AB").Value = tmp.Value & " " & tmp.Offset(0, 1).Value
End If
Next tmp
End Sub
Unfortunately, as soon as I enter first & last names while this code is active, the concatenated names are not listed one after another, but the last name in the list replaces the list title in AB2.
I guess the problem lies somewhere within the loop process, but I can't seem to figure out the logic behind it. I'd be thankful for any suggestions to solve that problem!
The problem is that the following instruction
Sheet11.Cells(Cells(Rows.Count, "AB").End(xlUp).Row + 1, "AB").Value
returns the same cell each time the loop is repeated. You can replace this whole line for example by this:
Range("AB" & tmp.Row).Value = tmp.Value & " " & tmp.Offset(0, 1).Value
Whenever you use a Worksheet_Change event macro to change the values of cell on the same worksheet, you need to turn off event handling or the value change will trigger a new event and the Worksheet_Change will try to run on top of itself. This also holds true for other worksheets that contain a Worksheet_Change unless you want the change in value to force the event. Similarly, the Target can represent more than a single cell (e.g. a paste operation) so you need to deal with the individual cells in the Intersect, not the Intersect as a whole.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B:C")) Is Nothing Then
On Error GoTo bm_Safe_exit
Application.EnableEvents = False
Dim bc As Range
For Each bc In Intersect(Target, Columns("B:C"))
Sheet11.Cells(bc.Row, "AB") = _
Join(Array(Cells(bc.Row, "B").Value2, Cells(bc.Row, "C").Value2))
Next bc
End If
bm_Safe_exit:
Application.EnableEvents = True
End Sub
I've used the Join Function as the string concatenation mechanism. While any character can be supplied as a connector in a Join, the default is a space.
I suggest a faster Change event - you don't need to loop over all rows for every update
This will add new entries and update existing ones:
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .CountLarge = 1 And .Row >= 3 And (.Column = 3 Or .Column = 4) Then
Dim cel As Range
Set cel = Cells(.Row, 3)
If Len(cel) > 0 And Len(cel.Offset(0, 1)) > 0 Then
Worksheets("Sheet11").Range("AB" & .Row) = cel & " " & cel.Offset(0, 1)
End If
End If
End With
End Sub
How do I code Excel VBA to retrieve the url/address of a hyperlink in a specific cell?
I am working on sheet2 of my workbook and it contains about 300 rows. Each rows have a unique hyperlink at column "AD". What I'm trying to go for is to loop on each blank cells in column "J" and change it's value from blank to the hyperlink URL of it's column "AD" cell. I am currently using this code:
do while....
NextToFill = Sheet2.Range("J1").End(xlDown).Offset(1).Address
On Error Resume Next
GetAddress = Sheet2.Range("AD" & Sheet2.Range(NextToFill).Row).Hyperlinks(1).Address
On Error GoTo 0
loop
Problem with the above code is it always get the address of the first hyperlink because the code is .Hyperlinks(1).Address. Is there anyway to get the hyperlink address by range address like maybe sheet1.range("AD32").Hyperlinks.Address?
This should work:
Dim r As Long, h As Hyperlink
For r = 1 To Range("AD1").End(xlDown).Row
For Each h In ActiveSheet.Hyperlinks
If Cells(r, "AD").Address = h.Range.Address Then
Cells(r, "J") = h.Address
End If
Next h
Next r
It's a bit confusing because Range.Address is totally different than Hyperlink.Address (which is your URL), declaring your types will help a lot. This is another case where putting "Option Explicit" at the top of modules would help.
Not sure why we make a big deal, the code is very simple
Sub ExtractURL()
Dim GetURL As String
For i = 3 To 500
If IsEmpty(Cells(i, 1)) = False Then
Sheets("Sheet2").Range("D" & i).Value =
Sheets("Sheet2").Range("A" & i).Hyperlinks(1).Address
End If
Next i
End Sub
My understanding from the comments is that you already have set the column J to a string of the URL. If so this simple script should do the job (It will hyperlink the cell to the address specified inside the cell, You can change the cell text if you wish by changing the textToDisplay option). If i misunderstood this and the string is in column AD simply work out the column number for AD and replace the following line:
fileLink = Cells(i, the number of column AD)
The script:
Sub AddHyperlink()
Dim fileLink As String
Application.ScreenUpdating = False
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 4 To lastrow
fileLink = Cells(i, 10)
.Hyperlinks.Add Anchor:=Cells(i, 10), _
Address:=fileLink, _
TextToDisplay:=fileLink
Next i
End With
Application.ScreenUpdating = True
End Sub
Try to run for each loop as below:
do while....
NextToFill = Sheet2.Range("J1").End(xlDown).Offset(1).Address
On Error Resume Next
**for each** lnk in Sheet2.Range("AD" & Sheet2.Range(NextToFill).Row).Hyperlinks
GetAddress=lnk.Address
next
On Error GoTo 0
loop
This IMO should be a function to return a string like so.
Public Sub TestHyperLink()
Dim CellRng As Range
Set CellRng = Range("B3")
Dim HyperLinkURLStr As String
HyperLinkURLStr = HyperLinkURLFromCell(CellRng)
Debug.Print HyperLinkURLStr
End Sub
Public Function HyperLinkURLFromCell(CellRng As Range) As String
HyperLinkURLFromCell = CStr(CellRng.Hyperlinks(1).Address)
End Function
I need to apply "IF "formula in whole C column till has last value in the sheet using VBA .
but i am getting error 438 if i use the following code . Plz help me
Sub test11()
With Sheets("Sheet")
.Range("c1:c" & .Cells(.Rows.Count, "A").End(xlUp).Row).Formula = "=IF(B1="",TRIM(A1),TRIM(B1))"
End With
End Sub
So your sheet name is Sheet or Sheet1? And OP mentioned Sheet name is Sheet2. That removes one error. Secondly, you need to set D column as .Cells(.Rows.Count,"D").End(xlUp).Row) instead of A column.
Here is a very ugly code to try out: It takes last used row in count into the Long variable. Then set the range accordingly for setting up the formula using AutoFill.
Sub test11()
Dim l As Long
l = Sheets(1).Range("d1:d" & Sheets(1).Cells(Sheets(1).Rows.Count, "D").End(xlUp).Row).Count
With Sheets("Sheet1")
.Range("d1").Formula = "=IF(IsNull(B1),TRIM(A1),TRIM(B1))"
.Range("d1").AutoFill Destination:=Range("d1:d" & l), Type:=xlFillDefault
End With
End Sub
Your logic seems a bit strange, but this works:
Sub test11()
With Sheets("Sheet1")
.Range(.Range("c1"), .Range("C" & .Rows.Count).End(xlUp)) = "=IF(B1="""",TRIM(A1),TRIM(B1))"
End With
End Sub
You need to double the quotes within quotes in VBA.
Another variant:
Sub test12()
With Sheets("Sheet1")
Intersect(.Range("c1").CurrentRegion, .Range("C:C")).Formula = "=IF(B1="""",TRIM(A1),TRIM(B1))"
End With
End Sub