I am trying to write vba code which looks for the term "drek" in column BI. If the term is present in the cell it will then offset (0,1) the value "1".
I have used the code below, however it will only find and offset the first "drek" and then stop. I need it so it will do this with every "drek" it finds.
How might I do this?
Sub find_drek()
Dim rng As Range
Dim cl As Range
Dim sFind As String
sFind = "drek"
Set rng = Range("BI2", Range("BI65536").End(xlUp))
Set cl = rng.find(sFind, LookIn:=xlValues)
If Not cl Is Nothing Then cl.Offset(0, 1).Value = "1"
End Sub
You can try this:
Dim rng As Range
Dim sFind As String
sFind = "drek"
For Each rng In Range("BI2", Range("BI65536").End(xlUp))
If Not rng.Find(sFind, LookIn:=xlValues) Is Nothing Then
rng.Offset(0, 1).Value = "1"
End If
Next rng
Thus, you don't need another range object.
Related
I am struggling to find any info on the internet to make this work, please help me out.
I would like a function to do the following (summarized below)
As you can see column A3:A7 has a number in each cell and a colour associated with that specific number.
I would like the code to scan through A3:A7 and match the numbers in C3:C7 with the colour that's already applied. (See below for detailed explanation)
For instance, A3 has a value of 1 and is yellow, I would like the code to scan through all numbers in Column C (C3:C7) and identify that C6 is also 1, therefore it will apply yellow to C6.
Initial:
Final:
Also can this be done across two different Sheets.For example lets say A3:A7 is on Sheet1 and I want to find matches in C3:C7 in Sheet2
Sub ColourCells()
Dim Rng1 As Range, Rng2 As Range, Rng2Item As Range
Dim Rng1LRow As Long, Rng2LRow As Long
Dim Rng1Match As Variant
With Worksheets("Sheet1")
Rng2LRow = .Cells(.Rows.Count, 3).End(xlUp).Row
Set Rng2 = .Range("C3:C" & Rng2LRow)
End With
With Worksheets("Sheet2")
Rng1LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Rng1 = .Range("A3:A" & Rng1LRow)
End With
For Each Rng2Item In Rng2
With Rng2Item
Rng1Match = Application.Match(.Value, Rng1, 0)
If IsError(Rng1Match) Then
GoTo NextItem
Else
.Interior.Color = Application.Index(Rng1, Rng1Match, 0).Interior.Color
End If
End With
NextItem:
Next Rng2Item
End Sub
Sub test()
Dim rng1 As Range, rng2 As Range, rng As Range
Set rng1 = Range("A3:A7")
Set rng2 = Range("C3:C7")
For Each rng In rng2
With Application.WorksheetFunction
If .CountIf(rng1, rng.Value) > 0 Then rng.Interior.Color = .Index(rng1, .Match(rng.Value, rng1, 0), 1).Interior.Color
End With
Next rng
Set rng1 = Nothing
Set rng2 = Nothing
End Sub
Looking for help to achieve searching a range of cells E9:E with All cells containing "Accommodation & Transportation" and changing the value of the cells adjacent to them with 0. , I was not able to get anything online with similar topic and I'm not too good with VBA coding, though i am able to understand what the code will provide in results.
I Have a Commandbutton1 with the below code :
Sub CommandButton1_click()
Dim blanks As Excel.Range
Set blanks = Range("F9:F" & Cells(Rows.Count, 5).End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
blanks.Value = blanks.Offset(0, -1).Value
End Sub
Further i have a command button that will select only cells that are not blank. I need the above result because if the below code selects Non Blank cells from Columns E:F it wont be selecting cells adjacent to those containing "Accommodation & Transportation" as they are blank cells and it will return the error "Runtime Error '1004' This action wont work on multiple selections".
The below code acts the same as [Go to Special => Constants]
Sub SelectNonBlankCells()
Dim rng As Range
Dim OutRng As Range
Dim InputRng As Range
Dim xTitle As String
On Error Resume Next
xTitle = Application.ActiveWindow.RangeSelection.Address
Set InputRng = Range("E8:F500")
ActiveWindow.ScrollRow = 1
For Each rng In InputRng
If Not rng.Value = "" Then
If OutRng Is Nothing Then
Set OutRng = rng
Else
Set OutRng = Application.Union(OutRng, rng)
End If
End If
Next
If Not (OutRng Is Nothing) Then
OutRng.Select
End If
End Sub
Maybe you can try another approach, if your goal is to edit cells adjacent to certain cells. The code below is based on an example in the Help file of the Range.Find function:
Sub DoSomething()
Dim sh As Worksheet
Set sh = ActiveSheet
Dim checkRange As Range
Set checkRange = sh.Range("E8:F500") ' your intended range to search
Dim foundRange As Range
Set foundRange = checkRange.Find("Accommodation & Transportation")
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = checkRange.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub
Or even better, you could add some parameters to make it more reusable:
Sub Main()
DoSomething "Accommodation & Transportation", ActiveSheet.Range("E8:F500")
End Sub
Sub DoSomething(ByVal findWhat As String, ByVal searchWhere As Range)
Dim foundRange As Range
Set foundRange = searchWhere.Find(findWhat)
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = searchWhere.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub
https://i.stack.imgur.com/9aNsi.jpg
I learned VBA from scratch and started simple.
I just want to display the month name from the date format in Column B2: B690, and put it in Column A2: A690 .. but my code has an error.
can you help me find the right solution in coding?
Dim rng1, rng2 As Range
Set rng1 = Range("A2:A690")
Set rng2 = Range("B2:B690")
rng1.Value = WorksheetFunction.Text(rng2, "mmmm")
Try the next code, please:
Dim rng1, rng2 As Range
Set rng2 = Range("B2:B690")
rng2.Copy Range("A2")
Set rng1 = Range("A2:A690")
rng1.NumberFormat = "MMMM"
Or avoiding the use of clipboard:
Sub testTextMonthName()
Dim rng1, rng2 As Range
Set rng1 = Range("A2:A690")
Set rng2 = Range("B2:B690")
With rng1
.Value2 = rng2.Value2
.NumberFormat = "MMMM"
'.value = .Text 'if you need it as text, uncomment this line, please
End With
End Sub
I have a task to make a VBA macro based on few sections in .xls file.
I know that in this file it will always be three sections which starts with specific name in example file "Block". But starting row where "Block" is written each time could be different.
Example of .xls file:
enter image description here
My approach had been to search for address of each column containing string "Block"
And later make further code based on knowing there start of each block are.
My code so far:
Public Values
Sub Macro1()
FindAll ("Block")
Debug.Print Values
'
End Sub
Sub FindAll(text)
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
fnd = text
Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
'Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo NothingFound
End If
Set rng = FoundCell
'Loop until cycled through all unique finds
Do Until FoundCell Is Nothing
'Find next cell with fnd value
Set FoundCell = myRange.FindNext(after:=FoundCell)
'Add found cell to rng range variable
Set rng = Union(rng, FoundCell)
'Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then Exit Do
Loop
'Creates global value with all found adresses
Values = rng.Address
Exit Sub
Output Is received as intended:
$A$5,$A$8,$A$1
However I struggle to select element for further coding.
I tried:
Debug.Print Values.Rows.item(1).Adress
Debug.Print Values.Rows.item(1,1).Adress
Debug.Print Values.Rows.item(1)
Debug.Print Values.Rows.item(1,1)
But it yields "Run-time error '424' "
My desired output would be to create three variables containing addresses for these sections.
That
Debug.Print Section_1
Debug.Print Section_2
Debug.Print Section_3
Would yield:
$A$1
$A$5
$A$8
Is there a way to select nth element from union in VBA?
If you want to access the single cells of the range, you can simply loop over it:
Dim cell as Range
For Each cell In rng
Debug.Print cell.Address
Next
Could also be done using an index:
Dim i As Long
For i = 1 To rng.Count
Debug.Print rng(i).Address
Next
Now in your example, you combine single cells using Union. If you combine larger ranges and want to access those ranges, you can use the Areas-Property. However, Excel will optimize the areas, if you do Union(Range("A1"), Range("A2)), you will end up with one area A1:A2.
With ActiveSheet
Set rng = Union(.Range("D5:E16"), .Range("A1:F12"), .Range("X4"))
End With
Dim a As Range
For Each a In rng.Areas
Debug.Print a.Address
Next
For i = 1 to rng.Areas.Count
Debug.Print rng(i).Address
Next
Btw: Every Range (even a single cell) has the Areas-property set, so it's always safe to loop over the Areas of a range.
Try,
Public Values
Public rngDB() As Range
Sub Macro1()
Dim i As Integer
FindAll ("Block")
Debug.Print Values
For i = LBound(rngDB) To UBound(rngDB)
Debug.Print rngDB(i).Address
Debug.Print rngDB(i).Cells(1).Address
Debug.Print rngDB(i).Cells(1, 2).Address
Debug.Print rngDB(i).Cells(2, 1).Address
Next i
End Sub
Sub FindAll(text)
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
Dim sAddress() As String
Dim n As Integer
fnd = text
Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
'Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
'GoTo NothingFound
End If
Set rng = FoundCell
'Loop until cycled through all unique finds
Do
n = n + 1
ReDim Preserve rngDB(1 To n)
ReDim Preserve sAddress(1 To n)
Set rngDB(n) = FoundCell.CurrentRegion
sAddress(n) = rngDB(n).Address
Set FoundCell = myRange.FindNext(after:=FoundCell)
Loop While FoundCell.Address <> FirstFound
'Creates global value with all found adresses
If n Then
Values = Join(sAddress, ",")
End If
End Sub
tldr: Find cell(s) with part number xxxxx and add hyperlink to drawing on server.
We have a spreadsheet containing part numbers across multiple columns & rows. Our requirement is to add a hyperlink to parts' drawing, stored on our server. We have tried highlighting them as a group, but get the error
this can't be done on multiple range selection
We also want to keep the comment information intact, just to complicate it further.
Is there code we can use to search for part number xxxxx & add a hyperlink, then find the next cell and repeat the process?
We have found a "find all" code which highlights the cells, just need some help with the hyperlink issue.
Sub FindAll()
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
'What value do you want to find (must be in string form)?
fnd = "70005"
Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
'Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo NothingFound
End If
Set rng = FoundCell
'Loop until cycled through all unique finds
Do Until FoundCell Is Nothing
'Find next cell with fnd value
Set FoundCell = myRange.FindNext(after:=FoundCell)
'Add found cell to rng range variable
Set rng = Union(rng, FoundCell)
'Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then Exit Do
Loop
'Select Cells Containing Find Value
rng.Select
Exit Sub
'Error Handler
NothingFound:
MsgBox "No values were found in this worksheet"
End Sub
Your method can be simplified a bit. My suggestion is to create a function that will add your hyperlinks to any given area.
My test data is
Option Explicit
Sub test()
Dim linkCount As Long
linkCount = AddHyperLinkTo(FindArea:=Sheet1.UsedRange, _
FindThis:="red", _
Link:="https://google.com")
Debug.Print "found: " & linkCount
End Sub
Function AddHyperLinkTo(ByRef FindArea As Range, _
ByVal FindThis As Variant, _
ByVal Link As String) As Long
Dim numberFound As Long
Dim parentWS As Worksheet
Set parentWS = FindArea.Parent
Dim firstFind As Range
Dim findResult As Range
Set findResult = FindArea.Find(What:=FindThis, LookIn:=xlValues)
Set firstFind = findResult
Do Until findResult Is Nothing
parentWS.Hyperlinks.Add Anchor:=findResult, Address:=Link
numberFound = numberFound + 1
Set findResult = FindArea.Find(What:=FindThis, LookIn:=xlValues, After:=findResult)
If findResult.Address = firstFind.Address Then
Exit Do
End If
Loop
AddHyperLinkTo = numberFound
End Function