So, I am trying to get the cell address of selected cells based on a For Each loop.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim company As String
company = Range("H12").Value
Dim companyRange, cell As Range
companyRange = ThisWorkbook.Sheets("Bleh List").Range("A2:A20")
For Each cell In companyRange
If cell.Value <> vbNullString And cell.Value = company Then
Debug.Print "C : " & cell.Row
End If
Next cell
Application.EnableEvents = True
End Sub
However everytime I try to run this, I am returned a Object required error on the first line of the loop.
What should have been so trivial is creating this problem > why?
Thanks!
This is a common misconception:
Dim companyRange, cell As Range
Only cell is a Range. companyRange is a Variant. You need:
Dim companyRange as Range, cell as Range
Then you're missing a Set.
Set companyRange = ThisWorkbook.Sheets("Bleh List").Range("A2:A20")
Currently, companyRange = ThisWorkbook.Sheets("Bleh List").Range("A2:A20") is a 2D Variant array, not the Range object that you are expecting to iterate over.
Related
I have data in Column A in excel..I am iterating through column and i need to find if a cell value has hyperlink init.
LR=Activeworkbook.Worksheets("Emp").Range("A65000").End(xlup).Row
for j=1 to LR
if Thisworkbooks.Worksheets("Emp").cells(j,1)="" then 'Logic to find hyperlink
'Function
end if
next
Identify Cells Containing Hyperlinks
As Red Hare already mentioned in the comments, it is best tested with something like the following:
Dim cell As Range: Set cell = Sheet1.Range("A1")
If cell.Hyperlinks.Count > 0 Then ' has a hyperlink
Else ' has no hyperlink
End If
that is, using the Hyperlinks.Count property of the Hyperlinks object returned by the cell's Hyperlinks property which is a collection of hyperlinks in a range (in this case, a single cell). For a single cell, the Count property will return only 0 or 1 so you could actually use
If cell.Hyperlinks.Count = 1 Then ' has a hyperlink
instead.
Example Code
Option Explicit
Sub IdentifyCellsWithHyperlink()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' If it's not, modify accordingly.
Dim ws As Worksheet: Set ws = wb.Worksheets("Emp")
Dim rg As Range
Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim cell As Range
For Each cell In rg.Cells
If cell.Hyperlinks.Count > 0 Then ' has a hyperlink
Else ' has no hyperlink
End If
Next cell
End Sub
Here is something that can be used to run through each row to determine if it can be set as a hyperlink. Kinda hard to figure out what the range of possible solutions are that will work for you without fully understanding the context...
Private Sub cmdFollowLink_Click()
CreateHyperlink Me!cmdFollowLink, Me!txtSubAddress, _
Me!txtAddress
End Sub
Sub CreateHyperlink(ctlSelected As Control, _
strSubAddress As String, Optional strAddress As String)
Dim hlk As Hyperlink
Select Case ctlSelected.ControlType
Case acLabel, acImage, acCommandButton
Set hlk = ctlSelected.Hyperlink
With hlk
If Not IsMissing(strAddress) Then
.Address = strAddress
Else
.Address = ""
End If
.SubAddress = strSubAddress
.Follow
.Address = ""
.SubAddress = ""
End With
Case Else
MsgBox "The control '" & ctlSelected.Name _
& "' does not support hyperlinks."
End Select
End Sub
in a worksheet I want to select the inputbox's input i.e. suppose "A" which is incurred in multiple cells in multiple location. I want to select all the cells referring to letter "A" at the same time.
Option Explicit
Sub SelectBattleship()
Dim BattleShip As Range
Dim Name As String
Dim store As Variant
Dim cell As Range
Set BattleShip = Range("A1:J10")
Name = InputBox("Value?")
For Each cell In BattleShip
If cell = Name Then
store = cell.AddressLocal & cell.AddressLocal
End If
Next cell
store.Select
End Sub
I expect all the cells containing the letter "A" will be selected together.
Build a Union() and use it:
Option Explicit
Sub SelectBattleship()
Dim BattleShip As Range
Dim Name As String
Dim store As Variant
Dim cell As Range, rSelect As Range
Set BattleShip = Range("A1:J10")
Name = InputBox("Value?")
For Each cell In BattleShip
If cell.Value = Name Then
If rSelect Is Nothing Then
Set rSelect = cell
Else
Set rSelect = Union(rSelect, cell)
End If
End If
Next cell
If rSelect Is Nothing Then
Else
rSelect.Select
End If
End Sub
I'm currently working on the statement that implies, that if any of the cell value in the range of "G3:ED3" in the worksheet named "Matrix", matches the cell value in the range of "H3:H204" in the worksheet named "Staff" and any cell value in the range "G5:ED57" in the "Matrix" worksheet is numeric, then the value of the cell in a column B, that intersects the numeric value, is retrieving to the required cell address in the target template.
Here's what I have tried so far:
Dim rng1 As Range
Set rng1 = Worksheets("Matrix").Range("G3:ED3")
Dim rng2 As Range
Set rng2 = Worksheets("Staff").Range("H3:H204")
Dim rng3 As Range
Set rng3 = Worksheets("Matrix").Range("G5:ED57")
For Each cell In Range(rng1, rng2, rng3)
While IsNumeric(rng3) And rng1.Value = rng2.Value
Worksheets("Matrix").Columns("B").Find(0).Row =
Worksheets("TEMPLATE_TARGET").Value(12, 4)
Wend
I'm unsure how to define the statement, so the code would automatically retrieve the value of the cell in a column B, that intersects any cell that contains numeric value in the rng3. Any recommendations would be highly appreciated.
it's probably best you take a proper look into documentation / whatever learning resource you are using as you seem to have missunderstood how While works (alongside few other things)
While is a loop within itself, it does not act as an Exit Condition for the For loop.
With all that said, it's also unclear from your question what you're trying to achieve.
My presumption is, that you want to check for all the conditions and
then if they do match, you're looking to paste the result into the
"TEMPLATE" sheet
First we create a function th ceck for values in the two data ranges:
Private Function IsInColumn(ByVal value As Variant, ByVal inSheet As String) As Boolean
Dim searchrange As Range
On Error Resume Next ' disables error checking (Subscript out of range if sheet not found)
' the range we search in
If Trim(LCase(inSheet)) = "matrix" Then
Set searchrange = Sheets("Matrix").Range("G5:ED7")
ElseIf Trim(LCase(inSheet)) = "staff" Then
Set searchrange = Sheets("Staff").Range("H3:H204")
Else
MsgBox ("Sheet: " & inSheet & " was not found")
Exit Function
End If
On Error GoTo 0 ' re-enable error checking
Dim result As Range
Set result = searchrange.Find(What:=value, LookIn:=xlValues, LookAt:=xlWhole)
' Find returns the find to a Range called result
If result Is Nothing Then
IsInColumn = False ' if not found is search range, return false
Else
If IsNumeric(result) Then ' check for number
IsInColumn = True ' ding ding ding, match was found
Else
IsInColumn = False ' if it's not a number
End If
End If
End Function
And then we run the procedure for our search.
Private Sub check_in_column()
Dim looprange As Range: Set looprange = Sheets("Matrix").Range("G3:ED3")
Dim last_row As Long
For Each cell In looprange ' loops through all the cells in looprange
'utlizes our created IsInColumn function
If IsInColumn(cell.Value2, "Matrix") = True And _
IsInColumn(cell.Value2, "Staff") = True Then
' finds last actively used row in TEMPLATE_TARGET
last_row = Sheets("TEMPLATE_TARGET").Cells(Rows.Count, "A").End(xlUp).Row
' pastes the found value
Sheets("TEMPLATE_TARGET").Cells(last_row, "A") = cell.Value2
End If
' otherwise go to next cell
Next cell
End Sub
I redefined your ranges a little in my example for utility reasons but it works as expected
In my Matrix sheet: (staff sheet only contains copy of this table)
In my TEMPLATE_TARGET sheet after running the procedure.
Result as expected
If I understand well, I would have done something like this:
Option Explicit
Public Sub Main()
Dim wsMatrix As Worksheet: Set wsMatrix = ThisWorkbook.Worksheets("Matrix")
Dim rgMatrix As Range: Set rgMatrix = wsMatrix.Range("G3:ED3")
Dim cell As Range
Dim cellStaff As Range
Dim cellMatrix As Range
For Each cell In rgMatrix
If CheckRangeStaff(cell.Range) And CheckRangeMatrix() Then
'Process in a column B? Which sheet? Which cell? Which Process?
End If
Next cell
Debug.Print ("End program.")
End Sub
Public Function CheckRangeStaff(ByVal value As String) As Boolean
Dim wsStaff As Worksheet: Set wsStaff = ThisWorkbook.Worksheets("Staff")
Dim rgStaff As Range: Set rgStaff = wsStaff.Range("H3:H204")
Dim res As Boolean
Dim cell As Range
res = False
For Each cell In rgStaff
If cell.value = value Then
res = True
Exit For
End If
Next cell
CheckRangeStaff = res
End Function
Public Function CheckRangeMatrix() As Boolean
Dim wsMatrix As Worksheet: Set wsMatrix = ThisWorkbook.Worksheets("Matrix")
Dim rgMatrix As Range: Set rgMatrix = wsMatrix.Range("G5:ED57")
Dim res As Boolean
Dim cell As Range
res = False
For Each cell In rgMatrix
If IsNumeric(cell.value) Then
res = True
Exit For
End If
Next cell
CheckRangeMatrix = res
End Function
I have a list of links in more than 100000 cells.
I have to give hyperlinks to all of them but in Excel there is a limit of 65530 hyperlinks per worksheet.
How can I overcome the limit or how can I merge cells with equal values using VBA?
Sub AddHyperlinks()
Dim myRange As Range
Set myRange = Range("A1")
Dim hText As Variant
Do Until IsEmpty(myRange)
hText = Application.VLookup(myRange.Value, Worksheets("Sheet2").Range("A:B"), 2, False)
If IsError(hText) Then
hText = ""
Else
ActiveSheet.Hyperlinks.Add Anchor:=myRange, Address:="http://" + hText, TextToDisplay:=myRange.Text
hText = ""
End If
Set myRange = myRange.Offset(1, 0)
Loop
End Sub
The solution is as mentioned by #Rory:
Use the HYPERLINK function in your cell to emulate a hyperlink via a formula.
=HYPERLINK(url, displaytext)
This effectively bypasses the built-in Excel limit on "hard-coded" hyperlinks. Just tested this out after I hit the infamous error 1004:
Application-defined or object-defined error
when trying to create 100k+ hyperlinks in a sheet.
Just regular copy paste should work, but I can update the example (not tested) if it doesn't
Sub AddHyperlinks()
Dim rng As Range, rngFrom As Range, values, r
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1")
Set rngFrom = ThisWorkbook.Worksheets("Sheet2").Range("A:A")
rng.Worksheet.Hyperlinks.Delete ' remove all previous Hyperlinks
While rng(1) > ""
' resize the range to the same values
While rng(rng.Rows.Count + 1) = rng(1)
Set rng = rng.Resize(rng.Rows.Count + 1)
Wend
r = Application.Match(rng(1), rngFrom, 0)
If Not IsError(r) Then
values = rng.Value2 ' save the values
rngFrom(r, 2).Copy rng ' copy from the cell next to the match
rng.Value2 = values ' restore the values (not sure if it removes the links)
End If
Set rng = rng(rng.Rows.Count + 1) ' move to the next cell below
Wend
End Sub
If you store the URL in (eg) colA then something like this should work:
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim URL
If Target.Column <> 1 Then Exit Sub '<< only reacting if cell in URL column is right-clicked
URL = Target.Value
ThisWorkbook.FollowHyperlink URL
End Sub
Alternatively use the Before_DoubleClick event
It does mean you can't use a "friendly" link text such as "click here", but you could likely manage that if you store the URL text at a fixed offset and then read that instead of Target.Value
I suffered from the same problem and I know that I shouldn't have more than around 120000 rows that need hyperlinking so modified some code I found in another thread to this
Sub hyperlink2()
Dim Cell As Range
Dim Cell2 As Range
Dim rng As Range
Dim Rng2 As Range
Set rng = Range("X2:X60000")
For Each Cell In rng
If Cell <> "" Then ActiveSheet.Hyperlinks.Add Cell, Cell.Value
Next
Set Rng2 = Range("X60001:X120000")
For Each Cell2 In Rng2
If Cell2 <> "" Then ActiveSheet.Hyperlinks.Add Cell2, Cell2.Value
Next
End Sub
Hope that helps someone else who stumbles upon this via google (like I did) looking for a workable solution...
The 255 character limit applies to the limit of character that can be put in one cell's formula. A common approach to this is by splitting the link into multiple cells and using a formula to combine them.
=HYPERLINK(A1&A2,"Click Here")
Here's what I need to do:
1) Loop through every cell in a worksheet
2) Make formatting changes (bold, etc) to fields relative to each field based on the value
What I mean is that if a field has a value of "foo", I want to make the field that is (-1, -3) from it bold, etc. I tried to do this with the following script with no luck.
Thanks
Johnny
Pseudo Code to Explain:
For Each Cell in WorkSheet
If Value of Cell is 'Subtotal'
Make the cell 2 cells to the left and 1 cell up from here bold and underlined
End If
End ForEach
The Failed Macro (I don't really know VB at all):
Sub Macro2()
'
'
'
Dim rnArea As Range
Dim rnCell As Range
Set rnArea = Range("J1:J2000")
For Each rnCell In rnArea
With rnCell
If Not IsError(rnCell.Value) Then
Select Case .Value
Case "000 Total"
ActiveCell.Offset(-1, -3).Select
ActiveCell.Font.Underline = XlUnderlineStyle.xlUnderlineStyleSingleAccounting
End Select
End If
End With
Next
End Sub
Option Explicit
Private Sub macro2()
Dim rnArea As Range
Dim rnCell As Range
' you might need to change the range to the cells/column you want to format e. g. "G1:G2000" '
Set rnArea = Range("J1:J2000")
For Each rnCell In rnArea
With rnCell
If isBold(.Offset(1, 3).Value) Then
.Font.Bold = True
End If
If isUnderlined(.Offset(1, 3).Value) Then
'maybe you want this: .Font.Underline = xlUnderlineStyleSingle '
.Font.Underline = xlUnderlineStyleSingleAccounting
End If
End With
Next
End Sub
Private Function isBold(cellValue As Variant) As Boolean
Dim myList() As Variant
Dim listCount As Integer
Dim i As Integer
myList = Array("Totals", "FooTotal", "SpamTotal")
listCount = 3
isBold = False
For i = 0 To listCount - 1
If cellValue = myList(i) Then
isBold = True
Exit Function
End If
Next i
End Function
Private Function isUnderlined(cellValue As Variant) As Boolean
Dim myList() As Variant
Dim listCount As Integer
Dim i As Integer
myList = Array("FooTotal", "SpamTotal")
listCount = 2
isUnderlined = False
For i = 0 To listCount - 1
If cellValue = myList(i) Then
isUnderlined = True
Exit Function
End If
Next i
End Function
I added two functions but it should have also worked with an extensive if / else if / else.
Based on the comments on the solution above, i think this might be helpful
Sub FormatSpecialCells()
Dim SearchRange As Range
Dim CriteriaRange As Range
Set SearchRange = Range("A2:A24")
Set CriteriaRange = Range("C2:C5")
Dim Cell As Range
For Each Cell In SearchRange
TryMatchValue Cell, CriteriaRange
Next
End Sub
Private Sub TryMatchValue(CellToTest As Range, CellsToSearch As Range)
Dim Cell As Range
For Each Cell In CellsToSearch
If Cell.Value = CellToTest.Value Then
Cell.Copy
CellToTest.PasteSpecial xlPasteFormats, xlPasteSpecialOperationNone, False, False
End If
Next
End Sub
This does not fully accomplish your goal. What it does is it searches a specified list of cells, and it matches them against a seperate list of cells. If it matches the values, it takes the FORMAT of the second list of cells and applies it to the cell it matched in the first list of cells. You can modify this by changing the TryMatchValue function so that instead of matching the CellToTest, it pastes the format onto another cell which is 2 across and one up.
This has the advantage that, if you want to add more values and different formats, you only need to go to your excel sheet and add more values. Also you only need to change the format on that value.
An example would be...
Have the cells you are searching in A1:D1000
Have these values in cells E2:E6...
Subtotal (which is bold and underlined)
Total (which is bold, underlined and italic)
Net (which is bold underlined and Red)
etc...
then when it hits Subtotal, it will change the cell to be bold and underlined.
When it hits Total it will change the cell to be bold underlined and italic
etc etc...
hope this helps
Would the conditional formatting functionality in excel give you what you need without having to write a macro?