VBA - update find function to loop through rows and move on if value isn't there - excel

Trying to put together a macro that searches each row to see if it contains 7 search terms (see "Warranty:" example below). If the cell starts with one of the phrases (like "Warranty:"), then that cell is pasted in a specific cell (same row but different column) in another worksheet.
Issues:
Had trouble with the macro until I added the select function - I know this slows them down, but I couldn't figure out a way to do this without it
Can't figure out how to get it to loop through all rows
Errors if the row doesn't have the word - need it to just keep going through
Sub FindTest()
Worksheets("Macro").Range("1:1").Find(What:="Warranty: ", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True).Copy
'Cell begins with "Warranty:" but text following varies
Sheets("CSV Upload").Select
Sheets("CSV Upload").Range("J1").Select
ActiveSheet.Paste
End Sub
UPDATE:
Sub FindTest()
Dim Macro As Worksheet: Set Macro = Sheets("Macro")
Dim CSV As Worksheet: Set CSV = Sheets("CSV Upload")
'On Error Resume Next
For R = 1 To Macro.UsedRange.Rows.Count
Set rng = Macro.Rows(R)
Dim FindRange As Range: Set FindRange = rng.Find(What:="Warranty:", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
'FindRange.Copy CSV.Range("J1")
'CSV.Cells(1, J) = Macro.Cells(FindRange)
Next
'On Error GoTo 0
End Sub

To loop through each row in the worksheet:
Dim ws As Worksheet: Set ws = Sheets("Macro")
Dim csv_upload As workseet: Set csv_upload = Sheets("CSV Upload")
For r = 1 To ws.UsedRange.Rows.Count
Set rng = ws.Rows(r)
rng.Find(What:="Warranty: ", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
...
Next
Then to copy the values, depending on which cells you need to copy
csv_upload.cells(dest_row, dest_col) = ws.cells(orig_row, orig_col)
For it to continue when you have an error, you can tell it to resume
On Error Resume Next
' potential for error to be raised
' Don't use this unless you know you are going to get a specific
' error and know there are no unintended consequences of ignoring it.
On Error GoTo 0
Using the code in your update, the following code should work for you.
Sub FindWarranty()
Dim Macro As Worksheet: Set Macro = Sheets("Macro")
Dim CSV As Worksheet: Set CSV = Sheets("CSV Upload")
Dim rng As Range, FindRange As Range
Dim Phrase As String
Phrase = "Warranty:"
For r = 1 To Macro.UsedRange.Rows.Count
Set rng = Macro.Rows(r)
Set FindRange = rng.Find(What:=Phrase, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
If Not FindRange Is Nothing Then
' Set destination cell to what you need it to be
c = 1
CSV.Cells(r, c) = FindRange
End If
Next
End Sub
A slightly more elegant way that Quicksilver alluded to is:
Sub FindWarrantys()
Dim Macro As Worksheet: Set Macro = Sheets("Macro")
Dim CSV As Worksheet: Set CSV = Sheets("CSV Upload")
Dim FoundCell As Range, FirstAddr As String
Dim Phrase As String, c As Integer
Phrase = "Warranty:"
' Find the first occurrence. The after variable is set to the
' last cell so that it will start searching from the beginning.
Set FoundCell = Macro.UsedRange.Find(what:=Phrase, _
after:=Macro.UsedRange.Cells(Macro.UsedRange.Cells.Count))
' Save the address of the first occurrence to prevent an infinite loop
If Not FoundCell Is Nothing Then
FirstAddr = FoundCell.Address
End If
' Loop through all finds
Do Until FoundCell Is Nothing
c = 1 ' Adjust for logic to determine which column
CSV.Cells(FoundCell.Row, c) = FoundCell
' Find the next occurrence
Set FoundCell = Macro.UsedRange.FindNext(after:=FoundCell)
' Break if we're back at the first address
If FoundCell.Address = FirstAddr Then
Exit Do
End If
Loop
End Sub

Related

.FindNext keeps returning to the first match, instead of the next

I have a SourceFile.xlsm that contains an X number of field definitions and their contents:
I want to put the contents of these fields into a TargetFile.xlsx, that may contain 0 or more of those field definitions:
The expected end result would be this:
But the actual end result is always this:
And that is because this line in the code below:
Set source_range = sourceSheet.Cells.FindNext(source_range)
always keeps coming back to the first occurrence (cell B5, containing "[Field 1]"), instead of the next (cell B6, containing "[Field 2]"):
Function CopyFromSourceToTarget()
Dim sourceWB As Workbook
Dim targetWB As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim source_range As Range
Dim target_range As Range
Dim FirstFound_source As String
Dim FirstFound_target As String
Set sourceWB = ActiveWorkbook
Set targetWB = Workbooks.Open("C:\TEMP\TargetFile.xlsx")
For Each sourceSheet In sourceWB.Worksheets
Set source_range = sourceSheet.Cells.Find("[", LookIn:=xlValues)
If Not source_range Is Nothing Then
FirstFound_source = source_range.Address
Debug.Print source_range.Value
Do
sourceWB.Activate
source_range.Select
For Each targetSheet In targetWB.Worksheets
Set target_range = targetSheet.Cells.Find(source_range.Value, LookIn:=xlValues)
If Not target_range Is Nothing Then
FirstFound_target = target_range.Address
Do
target_range.FormulaR1C1 = CStr(source_range.Offset(0, 1).Value)
Set target_range = targetSheet.Cells.FindNext(target_range)
If target_range Is Nothing Then Exit Do
Loop Until target_range.Address = FirstFound_target
End If
Next
Set source_range = sourceSheet.Cells.FindNext(source_range)
Debug.Print source_range.Value
Loop Until source_range.Address = FirstFound_source
End If
Next
End Function
I've tried several options, but all to no avail. Hopefully, someone here can help me along, because this seemingly very simple issue is driving me nuts.
Instead of this line:
Set source_range = sourceSheet.Cells.FindNext(source_range)
try this line:
Set source_range = sourceSheet.Cells.Find(What:="[", After:=source_range, LookIn:=xlValues)
I'd also add some more options to the Find like LookAt:= xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False, but it might not be necessary. Up to you.

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

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

How do I copy a dynamic range of data that follows a specific string from one sheet to another using VBA?

I am trying to search Sheet1 column a for the string " Testing Test" (yes with the spaces beforehand) then copy all rows below the row containing this string until a blank row is found, then I want to paste this selected range into column A row 1 on Sheet2. Next I want to search for the string " CASH" (again yes with the spaces beforehand) and i want to copy just the row that includes that to be pasted 2 rows underneath the last row of the first range pasted.
Here is what I have so far, which does not work... I do not even address the second component of finding the second string because i can't get the first... please assist, not sure why this is not working:
Sub Test()
Dim StringToFind As String
Dim i As Range
Dim cell As Range
StringToFind = " Testing Test"
With Worksheets("Sheet1")
Set cell = .Rows(1).Find(What:=StringToFind, lookat:=xlWhole, _
MatchCase:=False, searchformat:=False)
If Not cell Is Nothing Then
For Each i In .Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp))
If IsNumeric(i.Value) Then
If i.Value > 0 Then
i.EntireRow.Copy
Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
End If
Next i
Else
End If
End With
End Sub
Your question lacks a little detail. However, the code below will point you in the right direction. If you need help to manage it, please ask.
Sub FindAndCopy()
' 221
Dim WsS As Worksheet ' Source
Dim WsT As Worksheet ' Target
Dim Caps() As String ' captions to find
Dim Fnd As Range ' found caption
Dim Tgt As Range ' Target
Dim Arr As Variant ' Value of Fnd
Dim f As Integer ' loop counter: Caps
With ThisWorkbook
Set WsS = .Worksheets("Sheet1") ' change to suit
Set WsT = .Worksheets("Sheet2") ' change to suit
End With
Caps = Split("Testing Test,CASH", ",") ' extend to suit
For f = 0 To UBound(Caps)
Set Fnd = WsS.Rows(1).Find(Caps(f), LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=False)
If Fnd Is Nothing Then Exit For
Set Fnd = Fnd.Offset(1)
If f = 0 Then Set Fnd = Fnd.Resize(Fnd.End(xlDown).Row - 1, 1)
Arr = Fnd.Value ' copies Values, not Formulas
With WsT
Set Tgt = .Cells(1, 1)
If f Then Set Tgt = Tgt.Offset(.Cells(.Rows.Count, 1).End(xlUp).Row + 1)
If VarType(Arr) >= vbArray Then
Tgt.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
Else
Tgt.Value = Arr
End If
End With
Next f
End Sub
Observe that I discarded the leading spaces in your search criteria in favour of looking for a partial match in the Find function. In that way it doesn't matter how many spaces there are but it may cause confusion if there several matches. In that case you might reinstate the blanks by amending the array of Caps.

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

How to loop through several regions of a worksheet?

I'm looking for some VBA that will allow me to loop through several different REGIONS on a worksheet. Not individual cells, necessarily, but to jump from "currentregion" to the next "currentregion". And once the region is located, it should be selected and copied.
I've tried setting a StartCell (via Cells.Find(What:="*") and then using that cell to select the corresponding 'currentregion'. The issue is how to move to the next 'currentregion', until all 'currentregions' on the worksheet have been copied/pasted.
My results are inconsistent so far, where sometimes all the necessary regions are copied/pasted, but other times some of the regions are ignored (same exact worksheet, same exact data).
Set StartCell = Cells.Find(What:="*", _
After:=Cells(Rows.Count, Columns.Count), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)Do
'Select Range and copy it
If StartCell <> "" Then
StartCell.currentregion.CopyPicture
'Select a cell to paste the picture in
Range("A16").PasteSpecial
'Move to next range to be copied
Set StartCell = StartCell.End(xlToRight).End(xlToRight)
StartCell.Select
End If
Loop Until StartCell = ""
Something like that should work
Option Explicit
Public Sub ProcessEachRegion()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your sheet
Dim StartCell As Range
Set StartCell = ws.Range("A1") 'define start cell
Do Until StartCell.Column = ws.Columns.Count 'loop until end of columns
With StartCell.CurrentRegion
'do all your copy stuff here!
'.Copy
'Destination.Paste
Set StartCell = .Resize(1, 1).Offset(ColumnOffset:=.Columns.Count - 1).End(xlToRight)
End With
Loop
End Sub
It looks for the next region right to the previous one (regions 1 to 5 in the example below).
The main sub (I named it tgr) will call a function named GetAllPopulatedCells which defines a range for all populated cells in a worksheet. The .Areas property will let your loop through each region. It will then copy each Area/Region as a picture (still not sure why you want this) and put it in the destination cell, and then adjust the destination cell as needed so that all of the pasted images are stacked on top of each other.
Sub tgr()
Dim ws As Worksheet
Dim rAllRegions As Range
Dim rRegion As Range
Dim rDest As Range
Set ws = ActiveWorkbook.ActiveSheet
Set rAllRegions = GetAllPopulatedCells(ws)
Set rDest = ws.Range("A16")
If rAllRegions Is Nothing Then
MsgBox "No populated cells found in '" & ws.Name & "'. Exiting Macro.", , "Error"
Exit Sub
End If
For Each rRegion In rAllRegions.Areas
rRegion.CopyPicture
rDest.PasteSpecial
Set rDest = rDest.Offset(rRegion.Rows.Count)
Next rRegion
End Sub
Public Function GetAllPopulatedCells(Optional ByRef arg_ws As Worksheet) As Range
Dim ws As Worksheet
Dim rConstants As Range
Dim rFormulas As Range
If arg_ws Is Nothing Then Set ws = ActiveWorkbook.ActiveSheet Else Set ws = arg_ws
On Error Resume Next
Set rConstants = ws.Cells.SpecialCells(xlCellTypeConstants)
Set rFormulas = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Select Case Abs(rConstants Is Nothing) + 2 * Abs(rFormulas Is Nothing)
Case 0: Set GetAllPopulatedCells = Union(rConstants, rFormulas)
Case 1: Set GetAllPopulatedCells = rFormulas
Case 2: Set GetAllPopulatedCells = rConstants
Case 3: Set GetAllPopulatedCells = Nothing
End Select
Set ws = Nothing
Set rConstants = Nothing
Set rFormulas = Nothing
End Function

Resources