Search range for all cells with specific text and change the value of all adjacent cell to 0 - excel

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

Related

Selecting element from VBA union

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

Excel VBA - For Each Loop Alternative

I have a For Each Loop that looks for cells that contain a string with a wildcard and if that string is not bold. If those conditions are met then that cell's row is deleted. I believe the For Each Loop is inefficient, and even with only around 200 rows the code takes a few seconds to run. Is there a more efficient way to achieve these results?
Dim Cell As Range
Dim sheetRange As Range
Set sheetRange = ActiveSheet.UsedRange
For Each Cell In sheetRange
Set Cell = sheetRange.Find(What:="Total*", lookat:=xlPart)
If Not Cell Is Nothing Then
If Cell.Font.Bold = False Then
Cell.EntireRow.Delete
End If
End If
Next Cell
Please take a look at the code below and see if you can adapt it to your specific use case. The DeleteTotalRows subroutine uses the built-in .Find method to jump specifically to cells that include the value 'Total'. It passes each of these cells to the MergeDeleteRange subroutine. This sub will build a range to delete, which contains all rows with the Total word and bold font.
Report back if you run into issues.
Option Explicit
Sub DeleteTotalRows()
Dim fnd As Range
Dim rngToDelete As Range
Dim firstFnd As Range
Dim sht As Worksheet
'Update this
Set sht = Worksheets("Sheet2")
With sht
Set fnd = .Cells.Find(what:="Total", lookat:=xlPart)
If fnd Is Nothing Then Exit Sub
Set firstFnd = fnd
Do
MergeDeleteRange rngToDelete, fnd
Set fnd = .Cells.Find(what:="Total", lookat:=xlPart, after:=fnd)
Loop While fnd.Address <> firstFnd.Address
End With
If rngToDelete Is Nothing Then Exit Sub
rngToDelete.Delete
End Sub
Private Sub MergeDeleteRange(ByRef outputRng As Range, ByRef inputCell As Range)
'Not deleting if the cell isn't bold
If Not inputCell.Font.Bold Then Exit Sub
'Create output range if it's still empty
If outputRng Is Nothing Then Set outputRng = inputCell.EntireRow
'Since you are testing multiple columns, confirm that the
'row isn't already in the output range
If Not Intersect(inputCell, outputRng) Is Nothing Then
Exit Sub
End If
Set outputRng = Union(outputRng, inputCell.EntireRow)
End Sub

Find cell(s) with certain text and add hyperlinks in a loop

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

VBA in Excel: Runtime Error 1004

I am trying to do the following. I have several spreadsheets that are named something like "ITT_198763" where the ITT part stays the same but the number changes. I also have one tab called program where the 6 digit number is imported on row 40 (hence the RngToSearch below). I need the program to 1) find the "ITT" sheet for a certain 6 digit number, 2) identify the corresponding row in the "Program" tab, and copy information from the "ITT" tab to row 41 of the identified column. I will be copying more information from the ITT sheet to the specified column, but for now I am just trying to get it to work once.
From the MsgBox, I know it identifies the correct prjNumber (the 6 digit number), but I get the runtime 1004 error on the line Set RngDest. Any help will be appreciated!
Sub Summary_Table()
Dim wks As Worksheet
Dim RngToSearch As Range, RngDest As Range
Dim foundColumn As Variant
Dim prjNumber
For Each wks In ActiveWorkbook.Worksheets
If ((Left(wks.Name, 3) = "ITT")) Then
prjNumber = Right(wks.Name, 6)
MsgBox (prjNumber)
Set RngToSearch = Sheets("Program").Range("C40:q40")
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch, False)
With Sheets("Program")
Set RngDest = .Range(1, foundColumn) 'Project Name
End With
If Not IsError(foundColumn) Then
wks.Range("E2").Copy RngDest
End If
End If
Next wks
End Sub
I tried the .cell instead with the following code (all else is the same) and now get runtime error 13 on the Set RngDest line:
Set RngToSearch = Sheets("Program").Range("C40:q48")
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch.Rows(1), False)
With Sheets("Program")
Set RngDest = RngToSearch.Cells(1, foundColumn) 'Project Name
End With
Yuo are getting that error because foundColumn has an invalid value. Step through the code and see what is the value of foundColumn
Here is an example which works.
Sub Sample()
Dim RngDest As Range, RngToSearch As Range
foundColumn = 1
Set RngToSearch = Sheets("Program").Range("C40:q40")
Set RngDest = RngToSearch.Cells(1, foundColumn)
Debug.Print RngDest.Address
End Sub
Add MsgBox foundColumn before the line Set RngDest = RngToSearch.Cells(1, foundColumn) and see what value do you get. I guess the line
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch, False)
is not giving you the desired value. Here is the way to reproduce the error.
EDIT (Solution)
You need to handle the situation when no match is found. Try something like this
Sub Sample()
Dim RngDest As Range, RngToSearch As Range
Set RngToSearch = Sheets("Program").Range("C40:q40")
foundcolumn = Sheets("Program").Application.Match(1, RngToSearch, False)
If CVErr(foundcolumn) = CVErr(2042) Then
MsgBox "Match Not Found"
Else
Set RngDest = RngToSearch.Cells(1, foundcolumn)
'
'~~> Rest of the code
'
End If
End Sub
You are looking for the Cells function, which has the prototype .Cells([RowIndex], [ColumnIndex]). The Range function takes either a string with a range name (like "A1", or a named range), or other range references.
I figured it out! Found column was the problem. Combining that with the help from the other commenters, the following works:
Sub Summary_Table()
Dim wks As Worksheet
Dim RngToSearch As Range, RngDest As Range
Dim foundColumn As Variant
Dim prjNumber
For Each wks In ActiveWorkbook.Worksheets
If ((Left(wks.Name, 3) = "ITT")) Then
prjNumber = Right(wks.Name, 6)
MsgBox (prjNumber)
Set RngToSearch = Sheets("Program").Range("a40:q48")
foundColumn = Sheets("Program").Rows(40).Find(what:=prjNumber, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False).Column
MsgBox (foundColumn)
With Sheets("Program")
Set RngDest = RngToSearch.Cells(2, foundColumn) 'Project Name
Debug.Print RngDest.Address
End With
If Not IsError(foundColumn) Then
wks.Range("E3").Copy RngDest
End If
End If
Next wks
End Sub

In range find this and do that

Have a range of cell with column headings as weeks In the range of cells I want to look for a number, say
1 if it finds a 1 then look at a column in said row for a variable, 2 or 4 whatever Now I want to put a triangle (can be copy and paste a cell) in the cell that has the "1" in it then skip over the number of week variable and add another triangle and keep doing this until the end of the range. Then skip down to the next row and do the same, until the end of the range.
Then change to the next page and do the same thing... through the whole workbook.
I think I have it done, don't know if it's the best way.
I get a error 91 at the end of the second loop, the first time the second loop ends it goes through the error code.
The second time the second loop ends it errors.
I don't understand it runs through once, but not twice.
Sub Add_Triangles2()
Dim Rng As Range
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Dim ws As Worksheet
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Worksheets(1).Activate
Worksheets(1).Range("A1").Select ' Has item to be pasted (a triangle)
Selection.Copy
For Each ws In Worksheets
Worksheets(ws.Name).Activate
With Range("C4:G25")
Set Rng = .Find(1, LookIn:=xlValues)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Activate
ActiveSheet.Paste
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
End With
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub
I was not able to get an Error 91 using the data set I built from your explanation, maybe a screenshot of the layout could help recreate the issue.
However, I would do something like this, it will look at the value of each cell in the range C4:G25, and if it equals 1, it will paste the symbol stored in Cell A1.
Sub Add_Triangles2()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
End If
Next Rng
Next ws
End Sub
I got it....
Sub Add_TriWorking()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
Rng.Activate
ActiveCell.Copy
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
End If
Next Rng
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub

Resources