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.
Related
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...
I have a sheet FC, with this sheet, I have column R, S and T filled.
I would prefer to have a code, which checks if R contains "invalid" and if S and t are filled, then it should filter complete row.
I know we can use isblank function to check whether the cell is blank or not,
but I am struck how I can use a filter function with these condition .Any help will be helpful for me. I am struck how I can proceed with a vba code. Apologize me for not having a code.
You will have to somehow specify last row:
Dim lastRow, i As Long
For i = 1 To lastRow 'specify lastRow variable
If InStr(1, LCase(Range("R" & i).Value), "invalid") > 0 And Range("S" & i).Value = "" And Range("T" & i).Value = "" Then
'do work
End If
Next i
In our If condition we check three things that you asked.
Try this
Sub Demo()
Dim lastRow As Long
Dim cel As Range
With Worksheets("Sheet3") 'change Sheet3 to your data sheet
lastRow = .Cells(.Rows.Count, "R").End(xlUp).Row 'get last row in Column R
For Each cel In .Range("R5:R" & lastRow) 'loop through each cell in range R5 to lase cell in Column R
If cel.Value = "invalid" And Not IsEmpty(cel.Offset(0, 1)) And Not IsEmpty(cel.Offset(0, 2)) Then
cel.EntireRow.Hidden = True 'hide row if condition is satisfied
End If
Next cel
End With
End Sub
EDIT :
To unhide rows.
Sub UnhideRows()
Worksheets("Sheet3").Rows.Hidden = False
End Sub
Assuming Row1 is the header row and your data starts from Row2, in a helper column, place the formula given below.
This formula will return either True or False, then you may filter the helper column with either True or False as per your requirement.
=AND(R2="Invalid",S2<>"",T2<>"")
In case your header row is different, tweak the formula accordingly.
sub myfiltering()
'maybe first row always 4
firstrow=4
'last, maybe R column alaways have any entered info, so let us see what is the last
lastrow=cells(65000,18).end(xlup).row
'go ahead
for myrow=firstrow to lastrow
if cells(myrow,18)="Invalid" and cells(myrow,19)="" and cells(myrow,20)="" then
Rows(myrow).EntireRow.Hidden = True
else
Rows(myrow).EntireRow.Hidden = false
end if
next myrow
msgbox "Filter completed"
end sub
hope this will help you :)
Why you need the vba code for this problem?
Its more simple if you add a new column with if & and formula, and autofiltering within the added col.
The formula may be similar like this in the U2 cell.
=if(and(R2="invalid";S2="";T2="");"x";"")
Also set autofilter to x. :)
I'm automating an update I have to do and part of the macro I want to write needs specific text from what gets populated.
I have the following types of text in the same column for hundreds of rows:
ScreenRecording^naushi02^procr^10035
procr^10635^ScreenRecording^misby01
ScreenRecording^liw03^procr^10046
I've bold the text I need. I want to either replace the whole text with just what I need or place what I need in the next column, same row.
I had wrote something which worked for 60 or so lines before I realised that there are variations in the format. For the main, it's all the same which is why I didn't realise at first and I've spent a lot of wasted time writing something that is now useless... so I'm asking for expert help please.
Once I've got what I need from the first row, I need to move down until the last entry repeating.
I had some code which obviously didn't work fully.
I have thought about using the text 'ScreenRecording' in a search along with the special character which I can't find on my keyboard and then trying to copy all text from that point upto and including the 2nd numerical character. I don't know how to do this, if it would work or even if it's a good idea but because I've spent so much time trying to figure it out, I need some help please.
Thanks in advance
If you always want to return the value after the word 'ScreenRecording`, you can use the following function to do so.
Include it in a SubRoutine to replace in place if needed:
Function SplitScreenRecording(sInput As String) As String
Dim a As Variant
Const SDELIM As String = "^"
Const LOOKUP_VAL As String = "ScreenRecording"
a = Split(sInput, SDELIM)
If IsError(Application.Match(LOOKUP_VAL, a, 0)) Then
SplitScreenRecording = CVErr(2042)
Else
SplitScreenRecording = a(Application.Match(LOOKUP_VAL, a, 0))
End If
End Function
Sub ReplaceInPlace()
Dim rReplace As Range
Dim rng As Range
Set rReplace = Range("A1:A3")
For Each rng In rReplace
rng.Value = SplitScreenRecording(rng.Value)
Next rng
End Sub
if you want to replace:
Sub main2()
Dim key As String
Dim replacementStrng As String
key = "ScreenRecording"
replacementStrng = "AAA"
With Worksheets("mysheet01").columns("A") '<--| change "mysheet01" and "A" to your actual sheet name and column to filter
.Replace what:=key & "^*^", replacement:=key & "^" & replacementStrng & " ^ ", LookAt:=xlPart
.Replace what:="^" & key & "^*", replacement:="^" & key & "^" & replacementStrng, LookAt:=xlPart
End With
End Sub
while if you want to place what you need in the next column:
Sub main()
Dim myRng As Range
Set myRng = GetRange(Worksheets("mysheet01").columns("A"), "ScreenRecording^") '<--| change "mysheet01" and "A" to your actual sheet name and column to filter
myRng.Offset(, 1) = "value that I need to place in next row" '<--| change the right part of the assignment to what you need
End Sub
Function GetRange(rng As Range, key As String) As Range
With rng
.AutoFilter Field:=1, Criteria1:="*" & key & "*" '<--| apply current filtering
If Application.WorksheetFunction.Subtotal(103, .Cells) > 0 Then '<--| if there are visible cells other than the "header" one
With .SpecialCells(xlCellTypeConstants)
If InStr(.SpecialCells(xlCellTypeVisible).Cells(1, 1), key & "^") > 0 Then
Set GetRange = .SpecialCells(xlCellTypeVisible) '<--|select all visible cells
Else
Set GetRange = .Resize(.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).row - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--|select visible rows other than the first ("headers") one
End If
End With
End If
.Parent.AutoFilterMode = False '<--| remove drop-down arrows
End With
End Function
I'm looking for a way to highlight cells in sheet1 if they match the value in sheet2. Here is the code I have, there aren't any errors coming up but it does nothing. Basically I thought a Do while loop to go through all the records until it hit a blank and then it would read the cell value selected by my offset and compare it to the next sheets cell value while staying on the same row, and if it matched it would highlight on sheet 1 but if it didn't it would move on. Let me know how much I'm off here as I don't have much VBA knowledge. Thanks.
Public Sub RoundedRectangle1_Click()
Dim resource As Range
Dim register As Range
Dim cancel As Range
Set resource = Worksheets("Resource List1").Cells(2, 4)
Set register = Worksheets("Registered List").Cells(2, 1)
Set cancel = Worksheets("Cancelled List").Cells(2, 1)
Call findRegister(resource, register)
End Sub
Public Sub findRegister(ByRef resource As Range, ByRef register As Range)
Dim i As Integer
i = 0
Do While resource.Offset(i, 3) <> ""
If resource.Offset(i, 3).Value = register.Range("A2").Value Then
resource.Offset(i, 3).Cells.Interior.ColorIndex = 37
End If
i = i + 1
Loop
End Sub
Your code is essentially correct, but I think you're having trouble with referencing the right cells. A good debugging technique would be to add .Cells.Interior.ColorIndex = 4 or something similar in your code to see visually whether you're referencing the proper cells. You can also put "F5", "F8", and breakpoints to good use in figuring out what's wrong. See http://www.excel-easy.com/vba/examples/debugging.html if you've never used these.
For example:
Do While resource.Offset(i, 3) <> "" '<--Insert a breakpoint on this line,
'then press "F8" to make sure the
'code inside your Do While loop is
'being executed
resource.Offset(i, 3).Cells.Interior.ColorIndex = 4
register.Range("A2").Cells.Interior.ColorIndex = 6
If resource.Offset(i, 3).Value = register.Range("A2").Value Then
resource.Offset(i, 3).Cells.Interior.ColorIndex = 40
End If
i = i + 1
Loop
Maybe something as simple as this . . . .
Sub Compare2Shts()
For Each Cell In Worksheets("CompareSheet#1").UsedRange
If Cell.Value <> Worksheets("CompareSheet#2").Range(Cell.Address) Then
Cell.Interior.ColorIndex = 3
End If
Next
For Each Cell In Worksheets("CompareSheet#2").UsedRange
If Cell.Value <> Worksheets("CompareSheet#1").Range(Cell.Address) Then
Cell.Interior.ColorIndex = 3
End If
Next
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