I want to amend the code below
I want the findwhat to pick text from a range ("a1:20")-which contains the list of text i want to look for
If it finds the text in the description in B, i want it to return the text it found e.g jo IN range c beside its description
Thanks
Option Explicit
Sub x()
Dim FindWhat, rngCell As Range, i As Integer
FindWhat = Array("Jo", "oa", "of", "koo")
For i = 0 To 3
For Each rngCell In Range("B2", Range("B" & Rows.Count).End(xlUp))
If InStr(rngCell, FindWhat(i)) <> 0 Then
rngCell.Offset(0, 1) = rngCell
rngCell.Offset(, 1).Resize(, 2).Copy
End If
Next rngCell
Next i
End Sub
Try this:
Option Explicit
Sub x()
Dim findRng As Range, _
targetRng As Range, _
findCell As Range, _
found As Range
Dim i As Integer
Dim firstFound As String, _
columnName As String
columnName = "B"
Set findRng = Range("A1:A20")
For Each findCell In findRng
Set targetRng = Range(columnName & "2", Range(columnName & Rows.Count).End(xlUp))
With targetRng
Set found = .Find(findCell.Value, LookIn:=xlValues, lookat:=xlPart)
If Not found Is Nothing Then
firstFound = found.Address
Do
found.Offset(0, 1).Value = found.Offset(0, 1).Value & findCell.Value & ", "
Set found = .FindNext(found)
Loop While Not found Is Nothing And found.Address <> firstFound
End If
End With
Next findCell
End Sub
Note that unless what you're doing is a little more complex than this, you can achieve this result using cell formulae. Read the help on the Index, Match and VLookup functions to see how to achieve this.
Related
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
Code finds the header row and correct column. I want to execute some code on the range starting one cell under the header row in the same column and down to the last row in the same column. I've tried to use offset to create the range but the offset fails every time. Can offset not be used this way?
Sub Del_Y_Rows()
Dim Rng, fcell, LastRow, SrchRng, sRNG, eRNG As Range
Dim Findstring As String
Findstring = "Header"
With Sheets("thisSheet")
Set SrchRng = .Range("a1:l15")
Set fcell = SrchRng.Find(What:=Findstring, _
LookAt:=xlWhole, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
MatchCase:=False)
LastRow = .Cells(Rows.Count, fcell.Column - 2).End(xlUp).Row
Debug.Print "fcell " & fcell.Address
sRNG = .Range(fcell).Offset(1, 0) 'this fails 'sRng = start of the range
Debug.Print "srng " & sRNG
eRng = .cells(LastRow, fcell.Column) 'eRng = end of the range
Rng = .Range(sRNG, eRng)
Debug.Print "rng is " & Rng.Address
End With
End Sub
fcell is a range and the RAnge() is not needed:
sRNG = fcell.Offset(1, 0)
One more thing, You will want to use a check to make sure the fcell is actually a range and not nothing.
Sub Del_Y_Rows()
Dim Rng As Range, fcell As Range, LastRow as Long , SrchRng As Range, sRNG As Range, eRNG As Range
Dim Findstring As String
Findstring = "Header"
With Sheets("thisSheet")
Set SrchRng = .Range("a1:l15")
Set fcell = SrchRng.Find(What:=Findstring, _
LookAt:=xlWhole, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
MatchCase:=False)
LastRow = .Cells(Rows.Count, fcell.Column - 2).End(xlUp).Row
If not fcell is nothing then
Debug.Print "fcell " & fcell.Address
set sRNG = fcell.Offset(1, 0) 'this fails 'sRng = start of the range
Debug.Print "srng " & sRNG
set eRng = .cells(LastRow, fcell.Column) 'eRng = end of the range
set Rng = .Range(sRNG, eRng)
Debug.Print "rng is " & Rng.Address
End If
End With
End Sub
You must use Set for objects.
Set sRNG = .Range(fcell).Offset(1, 0)
I have a range that contains different words in different columns the range would be DT21:EH400. I want to know if there is a way to search through that range and if there is a word copy and paste it to the same row it is on but in column B.
The built in Find functionality should be quicker than writing your own loop:
Sub findUsingFIND()
Dim searchString As String
searchString = Excel.Application.InputBox("Enter string please")
Dim targetArea As Range
Set targetArea = Excel.Application.InputBox("Select range to search", , , , , , , 8)
targetArea.Select
'Excel.ThisWorkbook.Sheets(1).Range("DT21:EH400").Select
Dim foundRange As Range
With targetArea
Set foundRange = _
.Find(What:=searchString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
If Not foundRange Is Nothing Then
ThisWorkbook.Sheets(1).Range("B" & foundRange.Row) = searchString
Else
MsgBox "Nothing found"
End If
End Sub
If there are several instances of the string then the above can be adapted to the following:
Sub findSeveralUsingFIND()
Dim searchString As String
searchString = Excel.Application.InputBox("Enter string please")
Dim targetArea As Range
Set targetArea = Excel.Application.InputBox("Select range to search", , , , , , , 8)
targetArea.Select
'Excel.ThisWorkbook.Sheets(1).Range("DT21:EH400").Select
Dim foundRange As Range
With targetArea
Set foundRange = _
.Find(What:=searchString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not foundRange Is Nothing Then
FirstAddress = foundRange.Address
Do
ThisWorkbook.Sheets(1).Range("B" & foundRange.Row).Value = searchString
Set foundRange = .FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> FirstAddress
Else
MsgBox "Nothing found"
End If
End With
End Sub
As #ChrisNeilsen points out there is a very fast method that would be preferable if you need to perform your search many times. This uses arrays. My understanding is relatively shallow as to why this approach is quick but I believe it is in connection with the way arrays store the data in a block of memory addresses that are next to each other. Here is a good comparison of different approaches:
http://fastexcel.wordpress.com/2011/10/26/match-vs-find-vs-variant-array-vba-performance-shootout/
Here is the macro using an array of variant type:
Sub findUsingVARARRAY()
Dim vArr As Variant, vRes As Variant
Dim j As Long
Dim n As Long
Dim searchString As String
searchString = Excel.Application.InputBox("Enter string please")
Dim targetArea As Range
Set targetArea = _
Excel.Application.InputBox(prompt:="Select range to search", Type:=8)
Dim firstRow As Long
vArr = targetArea.Value2
ReDim vRes(LBound(vArr, 1) To UBound(vArr, 1), 1 To 1)
Dim r As Long, c As Long
For r = LBound(vArr, 1) To UBound(vArr, 1)
For c = LBound(vArr, 2) To UBound(vArr, 2)
' use vbTextCompare for case insenstitive comapre
' use vbBinaryCompare for case senstitive comapre
If StrComp(vArr(r, c), searchString, vbTextCompare) = 0 Then
vRes(r, 1) = searchString
Exit For
End If
Next c, r
targetArea.EntireRow.Columns(2) = vRes
End Sub
The following code may work
It searches for the word in the range and sets the search word as a value in column B of the row where the search word was found
Dim strSearch as String
Dim rngData as Range
Dim rngCell as Range
strSearch = "Word to Search"
Set rngData = Range(Cells(21,124),Cells(400,138))
For each rngCell in rngData
If rngCell.value = strSearch Then
cells(rngcell.Row, 2).Value = strSearch
End if
Next rngCell
I wrote an Excel macro and it seems to work fine. It displays an inputbox and once I give the value in it. It saves that value into first cell of column C (C1). However the second time I run macro I want it to be written into C2 and keep all datas in different rows in column C but each time, it writes it into C1 and cause a data loss.
Sub DataInput()
Dim SearchTarget As String
Dim myRow As Long
Dim Rng As Range
Static PrevCell As Range
Dim FoundCell As Range
Dim CurCell As Range
Dim a As String
Dim Target As Range
'SearchTarget = "asdf"
SearchTarget = InputBox("Scan or type product barcode...", "New State Entry")
If PrevCell Is Nothing Then
myRow = Selection.Row
Set PrevCell = Range("C" & myRow)
End If
'Set Rng = Range("C:C,E:E") 'Columns for search defined here
Set Rng = Range("C:C,C:C") 'Columns for search defined here
With Rng
Set FoundCell = .Cells.Find(What:=SearchTarget, _
After:=PrevCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True)
End With
If FoundCell Is Nothing Then
MsgBox SearchTarget & " was not found."
Range("C1").Value = InputBox("code?")
Range("D1").Value = Now()
Else
FoundCell.Activate
' If PrevCell.Address = FoundCell.Address Then
' MsgBox "there's only one!"
' End If
ActiveCell.Offset(0, 1).Select
timestamp = Format(Now(), "dd-mmm-yy hh:mm")
ActiveCell = timestamp
ActiveCell = Now()
ActiveCell.Offset(0, 2).Select
ActiveCell = "T141000"
ActiveCell.Offset(0, 1).Select
Set PrevCell = FoundCell
End If
End Sub
The problem here lies in your if statement - you are always storing the newly entered codes in cells C1 and the date in D1. You need to dynamically work out the next available row number and use that instead. Try something like this:
Public Sub DataInput()
...
If FoundCell Is Nothing Then
MsgBox SearchTarget & " was not found."
Dim nextFreeRow As Integer
nextFreeRow = Range("C" & Rows.Count).End(xlUp).Row + 1
Range("C" & nextFreeRow).Value = InputBox("code?")
Range("D" & nextFreeRow).Value = Now()
Else
...
End If
...
End Sub
I have compiled a code that searches for a value in a excel file say for example that value is 'D0'. When i tested the Search code separately it worked. But, when i combine my search code with a code that loops through files it does not work . The problem found is that the search does not returns the value.I have pointed out in the code, the Part thats not working. All, I am trying to do is to combine a search code with a code which will pick up file names written in the column of an excel sheet and then open those files and execute the search code.
Sub MyMacro()
Dim MyCell, Rng As Range
Dim Fname As String
Dim FirstAddress As String
Set Rng = Sheets("Sheet1").Range("A1:A6") 'sets the range to Read from
For Each MyCell In Rng 'checks each cell in range
If MyCell <> "" Then 'Picks up the file name present in the cell
MyCell.Activate 'Activates the cell
Fname = ActiveCell.Value 'Assigns the value of the cell to fname
Application.ScreenUpdating = False
Set wb = Workbooks.Open("C:\Users\" & Fname, True, True)
'opens the file
wb.Worksheets("Sheet1").Activate 'activates the opened workbook
Call Find_String 'calls the search code
wb.Close SaveChanges:=False
End If
Next
End Sub
Sub Find_String()
Dim FirstAddress As String
Dim MySearch As Variant
Dim Rng As Range
Dim I As Long
Dim strMyValu
Dim Axis
Dim wb As Workbook
MySearch = Array("D0") 'value that needs to be searched
Set wb = ActiveWorkbook 'trying to bring the opened workbook as active sheet
With Sheets("Sheet1").Range("B1:H100")
For I = LBound(MySearch) To UBound(MySearch)
Set Rng = .Find(What:=MySearch(I), _After:=.Cells(.Cells.Count), _LookIn:=xlFormulas, _
LookAt:=xlWhole, _SearchOrder:=xlByRows, _SearchDirection:=xlNext, _MatchCase:=False)
If Not Rng Is Nothing Then 'this is the part not working
'It should return the search value instead it returns nothing
'so as the value returned by the code is nothing and hence the code goes to endif
FirstAddress = Rng.Address
Do
Sheets("Sheet1").Select 'Selecting sheet1 on opened file
Rng.Activate
strMyValue = ActiveCell.Offset(0, 6).Value 'Copying the offset value of the located cell
Axis = ActiveCell.Offset(0, 3).Value
Workbooks("book22.xlsx").Worksheets("Sheet2").Activate
'Activating the workbook where i want to paste the result
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = strMyValue
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Axis
wb.Activate
'Activating the opened file again for loop to search for more values
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End Sub
Kindly help.
I am struck. I am new to VBA. So, unable to figure out what went wrong as when i tested the search code seperately it worked. Is it something related to the activation of file opened?
When i open a file it is not activated and hence search runs on the workbook that contains the macro instead of the opened file and so its unable to return search value???
Thank you
Part of your problem is the naming of your variables and the changing workbook and worksheet contexts. Be specific in you naming of variables so that you know what it should be and it will help you debug.
Also you don't need to activate workbooks and worksheets to get values from the ranges and cells. just getting a reference to the sheet,range cell will allow you to get what you need.
See it this does the trick for you.
Option Explicit
Sub MyMacro()
Dim MyCell, Rng As Range
Dim Fname As String
Dim FirstAddress As String
Dim searchSheet As Worksheet
Dim copyToSheet As Worksheet
Dim copyToWorkbook As Workbook
Dim searchWorkbook As Workbook
Set copyToWorkbook = Workbooks.Open("C:\Temp\workbook22.xlsx")
Set copyToSheet = copyToWorkbook.Worksheets("Sheet2")
Set Rng = Sheets("Sheet1").Range("A1:A6") 'sets the range to Read from
For Each MyCell In Rng 'checks each cell in range
If MyCell <> "" Then 'Picks up the file name present in the cell
Fname = MyCell.Value 'Assigns the value of the cell to fname
Set searchWorkbook = Workbooks.Open("C:\Temp\" & Fname, True, True)
Set searchSheet = searchWorkbook.Worksheets("Sheet1") 'get a reference to the sheet to be searched
Find_String searchSheet, copyToSheet 'calls the search code with the referenece sheet
searchWorkbook.Close SaveChanges:=False
End If
Next
copyToWorkbook.Close True
End Sub
Sub Find_String(searchSheet As Worksheet, copyToSheet As Worksheet)
Dim FirstAddress As String
Dim MySearch As Variant
Dim Rng As Range
Dim I As Long
Dim strMyValue As String
Dim Axis
Dim foundCell As Range
MySearch = Array("D0") 'value that needs to be searched
With searchSheet.Range("B1:H100")
For I = LBound(MySearch) To UBound(MySearch)
Set Rng = .Find(What:=MySearch(I), After:=.Cells(.Cells.Count), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not Rng Is Nothing Then 'this is the part not working
'It should return the search value instead it returns nothing
'so as the value returned by the code is nothing and hence the code goes to endif
FirstAddress = Rng.Address
Do
strMyValue = Rng.Offset(0, 6).Value 'Copying the offset value of the located cell
Axis = Rng.Offset(0, 3).Value
copyToSheet.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = strMyValue
copyToSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Axis
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End Sub
Agreed with Nathan.
Also, always avoid Application.ScreenUpdating = False with mix of ActiveWorkbook, ActiveSheet, ActiveCell.
Your Find_String should reference the object instead of just range of the activeworkbook
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value
Set oWSResult = Workbooks("book22.xlsx").Worksheets("Sheet2")
oWSResult.Range("B" & ...
It is hard to debug if you presume the active objects are always the one you are after.
Here's a revamped version of the code. This should run more quickly, and the FindAll function is a bit more versatile.
Sub MyMacro()
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim wsFileNames As Worksheet
Dim DataBookCell As Range
Dim rngCopy As Range
Dim CopyCell As Range
Dim arrData(1 To 65000, 1 To 2) As Variant
Dim MySearch As Variant
Dim varFind As Variant
Dim BookIndex As Long
Dim DataIndex As Long
Set wbDest = ActiveWorkbook
Set wsFileNames = wbDest.Sheets("Sheet1")
Set wsDest = wbDest.Sheets("Sheet2")
MySearch = Array("D0")
For Each DataBookCell In wsFileNames.Range("A1", wsFileNames.Cells(Rows.Count, "A").End(xlUp)).Cells
If Len(Dir("C:\Users\" & DataBookCell.Text)) > 0 And Len(DataBookCell.Text) > 0 Then
With Workbooks.Open("C:\Users\" & DataBookCell.Text)
For Each varFind In MySearch
Set rngCopy = FindAll(varFind, .Sheets(1).Range("B1:H100"))
If Not rngCopy Is Nothing Then
For Each CopyCell In rngCopy.Cells
DataIndex = DataIndex + 1
arrData(DataIndex, 1) = CopyCell.Offset(, 3).Value
arrData(DataIndex, 2) = CopyCell.Offset(, 6).Value
Next CopyCell
End If
Next varFind
.Close False
End With
End If
Next DataBookCell
If DataIndex > 0 Then wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(DataIndex, UBound(arrData, 2)).Value = arrData
Set wbDest = Nothing
Set wsFileNames = Nothing
Set wsDest = Nothing
Set DataBookCell = Nothing
Set rngCopy = Nothing
Set CopyCell = Nothing
Erase arrData
If IsArray(MySearch) Then Erase MySearch
End Sub
Public Function FindAll(ByVal varFind As Variant, ByVal rngSearch As Range, _
Optional ByVal LookIn As XlFindLookIn = xlValues, _
Optional ByVal LookAt As XlLookAt = xlWhole, _
Optional ByVal MatchCase As Boolean = False) As Range
Dim rngAll As Range
Dim rngFound As Range
Dim strFirst As String
Set rngFound = rngSearch.Find(varFind, rngSearch.Cells(rngSearch.Cells.Count), LookIn, LookAt, MatchCase:=MatchCase)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Set rngAll = rngFound
Do
Set rngAll = Union(rngAll, rngFound)
Set rngFound = rngSearch.Find(varFind, rngFound, LookIn, LookAt, MatchCase:=MatchCase)
Loop While rngFound.Address <> strFirst
Set FindAll = rngAll
Else
Set FindAll = Nothing
End If
Set rngAll = Nothing
Set rngFound = Nothing
End Function