I have this sheet where I want to use Find and FindNext to search for values on another sheet BD and copy them to my main sheet Plan1 if the value on alocacao matches cells on Column 5.
I used to have 4 spaces with named ranges tecnico1, tecnico2, tecnico3 and tecnico4 to paste the values and the code works fine.
This is how it looks:
And the BD sheet:
And this is the code:
Sub VerifProd_Click()
Dim FoundCell As Range, FirstAddr As String, fnd As String, i As Long
fnd = Sheets(1).Range("alocacao").Value
Set FoundCell = Sheets("BD").Columns(5).Find(what:=fnd, _
After:=Sheets("BD").Cells(Rows.Count, 5), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If FoundCell Is Nothing Then Exit Sub
Do
i = i + 1
Sheets("Plan1").Range("tecnico" & i).Value = FoundCell.Offset(, -3).Value
Sheets("Plan1").Range("upps0" & i).Value = FoundCell.Offset(, -1).Value
Set FoundCell = Sheets("BD").Columns(5).FindNext(After:=FoundCell)
Loop Until FoundCell.Address = FirstAddr Or i >= 4
End Sub
However, now I realize that I'll need more fields because I maybe insert more than 4 tecnicos on an alocacao. So now this is how it looks:
And I just changed this part of the code:
If FoundCell Is Nothing Then Exit Sub
Do
i = i + 1
Sheets("Plan1").Range("tecnico" & i).Value = FoundCell.Offset(, -3).Value
Sheets("Plan1").Range("upps0" & i).Value = FoundCell.Offset(, -1).Value
Set FoundCell = Sheets("BD").Columns(5).FindNext(After:=FoundCell)
Loop Until FoundCell.Address = FirstAddr Or i >= 10
So I was expecting that it just fills 4 fields as I still have only 4 matches, but I got this result:
As I'm new using Find and FindNext, I really don't know what I have to change to fill the cells with the matches only without repeating it.
Any suggestions will help! Maybe there is something I couldn't notice there.
I just used the suggestion of #Luuklag and now it's working.
Sub VerifProd_Click()
Dim FoundCell As Range, FirstAddr As String, fnd As String, i As Long
fnd = Sheets(1).Range("alocacao").Value
Set FoundCell = Sheets("BD").Columns(5).Find(what:=fnd, _
After:=Sheets("BD").Cells(Rows.Count, 5), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not FoundCell Is Nothing Then
FirstAddr = FoundCell.Address
End If
If FoundCell Is Nothing Then Exit Sub
Do
i = i + 1
Sheets("Plan1").Range("tecnico" & i).Value = FoundCell.Offset(, -3).Value
Sheets("Plan1").Range("upps0" & i).Value = FoundCell.Offset(, -1).Value
Set FoundCell = Sheets("BD").Columns(5).FindNext(After:=FoundCell)
Loop Until FoundCell.Address = FirstAddr Or i >= 10
End Sub
Related
I would like to select the first non-blank row above the selected cell (minus offset). For example, if a find Machine 1 in the sheet Grupos Produção I want to return the ******* Grupo 1 ******* string.
********** Grupo 1 **********
Machine 1
Machine 2
I have the following so far, but it's not returning what I need.
Dim FindString As String
Dim Rng As Range
FindString = Lcell.Value
If Trim(FindString) <> "" Then
With Sheets("Grupos Produção").Range("A:Z")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
upperRow = .Cells(Rng.Row, Rng.Column - 1).End(xlDown).Row
Else
MsgBox "Nothing found"
End If
End With
End If
I'm not sure I understand your code, but I think you are looking for something like this:
...
...
If Not Rng Is Nothing Then
Do While Rng.Row > 1 And Rng.Offset(-1, 0).Value <> ""
Set Rng = Rng.Offset(-1, 0)
Loop
...
Once the cell is found, it works its way up until it finds an empty cell and stops just before.
This will find the first non-blank cell (which will indicate the row is not blank) above the selected cell.
You need to check for:
If the rest of the sheet is empty it will return the same address as your selection.
If all cells above the selection are empty it will start from the bottom of the sheet until it reaches your selection again.
As you said the first non-blank cell it's using the * wildcard to search, and to make it look up from the selection it uses xlPrevious.
Still need to check if rng is nothing in case the entire sheet is empty.
Sub Test()
Dim Rng As Range
With ThisWorkbook.Worksheets("Sheet1").Range("A:Z")
Set Rng = .Cells.Find(What:="*", _
After:=Selection, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If Not Rng Is Nothing Then
If Rng.Address = Selection.Address Or Rng.Row > Selection.Row Then
MsgBox "Nothing found"
Else
Rng.Select
End If
End If
End With
End Sub
I managed to get what I need based on #Sam 's answer
If Not Rng Is Nothing Then
Do While Rng.Row > 1 And Rng.Offset(-1, 0).Value <> ""
Set Rng = Rng.Offset(-1, 0)
Loop
grupo = Rng.Offset(-1, -1).Value
Lcell.Value = grupo
End If
I want to search Column 5 on sheet "BD" for all the entries that match a value called "alocacao" on my sheet "Plan1".
Then copy the value on Column 2 to the cell called "tecnico1" (the other cells are called "tecnico2, tecnico3 and tecnico4").
The cell with the value TESTE 2 is the "alocacao".
I tried Find and FindNext:
Sub VerifProd_Click()
Dim FoundCell As Range
Dim LastCell As Range
Dim FirstAddr As String
Dim fnd As String
Dim i As Long
i = 2
fnd = Sheets(1).Range("alocacao").Value
With Sheets("BD").Columns(5)
Set LastCell = .Cells(.Cells.Count)
End With
Set FoundCell = Sheets("BD").Columns(5).Find(what:=fnd, after:=LastCell)
If Not FoundCell Is Nothing Then
FirstAddr = FoundCell.Address
End If
Do Until FoundCell Is Nothing
Sheets("BD").Cells(i,2).Copy Sheets("Plan1").Range("tecnico" & i).Value
i = i + 1
Set FoundCell = Sheets("BD").Columns(5).FindNext(after:=FoundCell)
If FoundCell.Address = FirstAddr Then
Exit Do
End If
Loop
End Sub
I get
Run-time error 1004
but the code is not highlighted.
EDIT
I changed a part of it to test if it will paste the value on cell B26.
Now I get
Run-time error 438
With Sheets("BD").Columns(5)
Set LastCell = .Cells(.Cells.Count)
End With
Set FoundCell = Sheets("BD").Columns(5).Find(what:=fnd, after:=LastCell)
If Not FoundCell Is Nothing Then
FirstAddr = FoundCell.Address
End If
Do Until FoundCell Is Nothing
Sheets("Plan1").Range("B26") = FoundCell.Adress.Offset(0, -3).Value
Set FoundCell = Sheets("BD").Columns(5).FindNext(after:=FoundCell)
If FoundCell.Address = FirstAddr Then
Exit Do
End If
Loop
Ok supposing you have 4 named cells in sheet "Plan1" with names tecnico1, tecnico2, tecnico3 and tecnico4, I suggest the following modification, having in mind that we should stop at 4 matches which the number of named ranges tecnico:
Sub VerifProd_Click()
Dim FoundCell As Range, FirstAddr As String, fnd As String, i As Long
fnd = Sheets(1).Range("alocacao").value
Set FoundCell = Sheets("BD").Columns(5).Find(what:=fnd, _
After:=Sheets("BD").Cells(Rows.count, 5), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If FoundCell Is Nothing Then Exit Sub
FirstAddr = FoundCell.Adress
Do
i = i + 1
Sheets("Plan1").Range("tecnico" & i).value = FoundCell.Offset(,-3).Value2
Set FoundCell = Sheets("BD").Columns(5).FindNext(After:=FoundCell)
Loop Until FoundCell.Address = FirstAddr Or i >= 4
End Sub
.Find and .FindNext algorithm is used like below...
With Sheets("BD").Columns(5)
Set FoundCell = .Find(what:=fnd, after:=LastCell)
If Not FoundCell Is Nothing Then
FirstAddr = FoundCell.Address
Do
Sheets("BD").Cells(i, 2).Copy Sheets("Plan1").Range("tecnico" & i).Value
i = i + 1
Set FoundCell = .FindNext(FoundCell)
Loop While Not FoundCell Is Nothing And FirstAddr <> FoundCell.Address
End If
End With
I would like to call sub-routine to remove rows that contain a certain value in a cell from my column colCell. So we are creating a string that contains '' if it cannot identify any values on another sheet to create the string from.
aCell.Value = Replace(aCell.Value, Split(aCell.Value, ",")(1), "'" & Sheet5.Cells(colCell.Row, 2) & "'")
DeleteRows (colCell)
I thought I could call the sub-routine above and pass in the column variable?
Main sub-routine:
Sub Main()
Set wDFS = ThisWorkbook.Sheets("Data")
Set colCell = wDFS.Rows("1:1").Find(what:="New query", after:=wDFS.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not colCell Is Nothing Then
Set rng = wDFS.Range(wDFS.Cells(2, colCell.Column), wDFS.Cells(wDFS.UsedRange.Rows.Count, colCell.Column))
For Each aCell In rng
Set colCell = Sheet5.Range("A1:A" & Sheet5.UsedRange.Rows.Count).Find(what:=Replace(Split(aCell.Value, ",")(1), "'", ""), after:=wDFS.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not colCell Is Nothing Then
aCell.Value = Replace(aCell.Value, Split(aCell.Value, ",")(1), "'" & Sheet5.Cells(colCell.Row, 2) & "'")
DeleteRows (colCell)
Else
With Sheet5.Range("A" & Sheet5.Range("A" & Rows.Count).End(xlUp).Row + 1)
.Value = Replace(Split(aCell.Value, ",")(1), "'", "")
.Interior.Color = 255
End With
End If
Next aCell
Else
MsgBox "No new query column found in " & wDFS.Name & " sheet"
End If
End Sub
Sub-routine for deleting rows:
Sub DeleteRows(colCell)
Dim c As Range
Dim SrchRng
Set SrchRng = ActiveSheet.Range("Data", ActiveSheet.Range(colCell).End(xlUp))
Do
Set c = SrchRng.Find("''", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
End Sub
In th debug, it says there is an issue with the following line:
Set SrchRng = ActiveSheet.Range("DataFeedSheet", ActiveSheet.Range(colCell).End(xlUp))
I assume it is something related to the range I have specified.
How do you do this?
Thanks in advance!
Sub DeleteRow4()
Dim rng As Range, cell_search As Range, del As Range
Set rng = Intersect(Range("Data"), ActiveSheet.UsedRange)
For Each cell_search In rng
If (cell_search.Value) = "9999" Then
'Your specific cell value goes here
If del Is Nothing Then
Set del = cell_search
Else: Set del = Union(del, cell_search)
End If
End If
Next cell_search
On Error Resume Next
del.EntireRow.Delete
End Sub
I have a macro that until now was used just to search one cell from column F but now I must search for all the cell in column F. If value from F is found in range N:AN, offset(f,0,1) must have the cell value (found row , column AI).
Sub find()
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Sheet1").Range("f48").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("n:an")
Set Rng = .find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Sheets("Sheet1").Range("f48").Offset(0, 1).Value = Rng.Offset(0, 21).Value
Else
Sheets("Sheet1").Range("f48").Offset(0, 1).Value = "Nothing found"
End If
End With
End If
End Sub
Perhaps this, if I understand correctly (it does assume the value in F will only be found once at most).
Sub find()
Dim Rng As Range
Dim r As Range
With Sheets("Sheet1")
For Each r In .Range("F1", .Range("F" & .Rows.Count).End(xlUp))
If Trim(r) <> vbNullString Then
With .Range("n:an")
Set Rng = .find(What:=r.Value, _
LookAt:=xlWhole, _
MatchCase:=False)
If Not Rng Is Nothing Then
r.Offset(0, 1).Value = .Cells(Rng.Row, "AI").Value
'Else
' Sheets("Sheet1").Range("f48").Offset(0, 1).Value = "Nothing found"
End If
End With
End If
Next r
End With
End Sub
See if this is helpful. Its a bit of a change but I think it may be cleaner :)
Of course you need to adjust it for your offset criteria once you "find" a match in the N:NA range
Sub Dougsloop()
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim aRR As Variant
Set wsO = ThisWorkbook.Sheets("Sheet1")
aRR = wsO.UsedRange.Columns("N:NA")
Set rRng = ThisWorkbook.Sheets("Sheet1").Range("F1:F500")
For Each rCell In rRng.Cells
If Trim(rCell.Value) <> vbNullString Then
thisValue = rCell.Value
If IsError(Application.Match(aRR, thisValue, 0)) = True Then
'Generic Eror Handling
ElseIf IsError(Application.Match(aRR, thisValue, 0)) = False Then
'Stuff you do when you find the match
rCell.Offset(0, 1).Value = "found it"
End If
End If
Next rCell
End Sub
I've found different solution on the site but they don't solve my problem. The section below is the result of a find where the "FoundCell" address is returned to the worksheet.
What I'm attempting to do is return the "FoundCell" address to cell (1,1) and the rest directly below. I want what my debug line is doing to print on the spreadsheet.
Value Found In Cell: $F$2
Value Found In Cell: $F$5
Value Found In Cell: $F$8
Value Found In Cell: $F$9
The sheet "program index" contains columns A to F. I'm using the Find to search a comma delimited string in column F. Currently the code is returning the cell address in column F where the string is found. What I need to the entries in column A & B associated with the found address in column F.
Sub Find()
Dim SearchRange As Range
Dim FoundCells As Range
Dim FoundCell As Range
Dim Destination As Range
Dim c, d As Range
Dim Row As String
Dim FindWhat As Variant
Dim FindWhat2 As Variant
Set Destination = Sheets("Calculations").Cells(1, 1)
Set SearchRange = Sheets("Program Index").Range("F2:F1000")
Debug.Print Sheets("main").Range("F2")
Sheets("Calculations").Range("A2:A50").Clear
FindWhat = Sheets("Main").Range("F2")
FindWhat2 = "All"
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
Set c = Sheets("Calculations").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
For Each FoundCell In FoundCells
c.Value = FoundCell.Address
Set c = c.Offset(1, 0)
Next FoundCell
End If
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat2, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
Set c = Sheets("Calculations").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
For Each FoundCell In FoundCells
c.Value = FoundCell.Address
Set c = c.Offset(1, 0)
Next FoundCell
End If
End Sub
I believe the change i need should happen in the "FindAll" however I'm not sure where to modify.
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then 'modify to find program number and description
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
FoundCell.Copy Sheets("Calculations").Cells(Rows.Count, 1).End(xlUp).Offset(1,0)
EDIT: maybe this is what you're looking for:
Dim c as range
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
Set c = Sheets("Calculations").Cells(Rows.Count, 1).End(xlUp).Offset(1,0)
For Each FoundCell In FoundCells
Debug.Print "Value Found In Cell: " & FoundCell.Address
c.value = FoundCell.Address()
'add values from the same row as FoundCell
c.offset(0, 1).value = FoundCell.EntireRow.Cells(1).value 'from colA
c.offset(0, 2).value = FoundCell.EntireRow.Cells(2).value 'from colB
Set c = c.offset(1,0)
Next FoundCell
End If
To get your debug.print lines to show in Column A, rows 1 to n, you could do something like:
Dim FoundCells As Range, FoundCell As Range
Dim rDest As Range
Set rDest = Worksheets("Calculations").Range("A1")
'For testing
Set FoundCells = Union(Range("f2"), Range("f5"), Range("f8"), Range("f9"))
If FoundCells Is Nothing Then
rDest.Value = "Value Not Found"
Else
For Each FoundCell In FoundCells
rDest.Value = "Value Found In Cell: " & FoundCell.Address
Set rDest = rDest(2, 1)
Next FoundCell
End If