How can I enter value in excel cell contain many words and search for in database if any word in the search cell matched the words in database just appear for me
am trying to write code but the problem that the code search for one word only and if I write may words in cell the code doesn't work
Sub searchkey()
Dim i As Integer
Dim keyword As String
Dim findrow As Integer
Sheet1.Range("b5:b20").ClearContents
keyword = Sheets("Search").Range("B2").Value
findrow = Sheets("Database").Range("B30").End(xlUp).Row
Sheets("Database").Activate
For i = 2 To findrow
If Sheet2.Cells(i, 2) = keyword Then
Sheet2.Range(Cells(i, 2), Cells(i, 2)).Copy
Sheets("Search").Range("B20").End(xlUp).Offset(1, 0).PasteSpecial
End If
Next i
Sheet1.Activate
End Sub
You need to split the keyword into pieces (in below code, I've called them keywordpart) and search for each one:
Sub searchkey()
Dim i As Integer
Dim keyword As String, keywordpart As Variant
Dim findrow As Integer
Dim wsSearch As Worksheet
Dim wsDatabase As Worksheet
Set wsSearch = Sheets("Search")
Set wsDatabase = Sheets("Database")
wsSearch.Range("b5:b20").ClearContents
keyword = wsSearch.Range("B2").Value
findrow = wsDatabase.Range("B30").End(xlUp).Row
For Each keywordpart In Split(keyword, " ")
For i = 2 To findrow
If wsDatabase.Cells(i, 2) = keywordpart Then
wsDatabase.Range(Cells(i, 2), Cells(i, 2)).Copy
wsSearch.Range("B20").End(xlUp).Offset(1, 0).PasteSpecial
End If
Next i
Next
End Sub
I also took the liberty of tidying up your worksheet referencing - as you sometimes referenced them by name and other times by object name.
Related
This question already has answers here:
How to remove spaces from an entire Excel column using VBA?
(3 answers)
Closed 2 years ago.
I want to remove the extra spaces after the text "Denver Health " into "Denver Health" for the range in column A.
input:
Column A
"Denver Health Hospital "
"Pueblo Hospital "
output:
Column A
"Denver Health Hospital"
"Pueblo Hospital"
I have tried that code but it removes all the spaces
Sub SpaceKiller()
Worksheets("Sheet2").Columns("A").Replace _
what:=" ", _
Replacement:="", _
SearchOrder:=xlByColumns, _
MatchCase:=True
End Sub
Another attempt was
Sub trim()
Dim r As String
r = RTrim(Range("A2:A"))
End Sub
This will get the trailing spaces..
Sub TrimTrailingSpaces()
Dim LR As Long 'Use Long as Integer can only handle 32,767
Dim myRng As Range 'I am going to name the used range
Dim ws As Worksheet 'Declare worksheet as variable
Dim cll As Range
Set ws = ThisWorkbook.Worksheets("Sheet2") 'Want to be specific on the worksheet used
LR = ws.Cells(Rows.Count, 1).End(xlUp).Row 'Find the last row in Col A. Do not include the whole column of over 1 million cells
Set myRng = ws.Range(ws.Cells(2, 1), ws.Cells(LR, 1)) 'Declare the range used
For Each cll In myRng 'cll is a Cell in a Collection of Cells in a Range that we defined
cll = RTrim(cll) 'Looping through, modify each cell
Next cll 'Go to the next Cell
End Sub
You can write own function to delete all additional spaces from string. allow only one space
Function Remove2Spaces(text As String) As String
Dim i_Len As Integer
Dim ReturnText As String
i_Len = Len(text)
For i = 1 To i_Len
If Mid(text, i, 1) = " " Then
If Mid(text, i + 1, 1) = " " Then
text = Mid(text, 1, i) & Mid(text, i + 2)
i = i - 1
End If
End If
Next i
Remove2Spaces = text
End Function
to get result place inside sub like below
sub Test()
MsgBox Remove2Spaces(ActiveSheet.Range("A3"))
end sub
I'm creating a UserForm with a textbox that the user will fill in with a list of names delimited by "; ". These names are found in Column D on my sheet. For each name, I'd like to copy and paste the whole row to another sheet and then delete the row in the original sheet. I am running into a couple of roadblocks that I haven't been able to solve.
Private Sub OK_Click()
Application.Volatile
Dim x As Integer
Dim PINamesArray As String
Dim size As Long
Dim SearchRange As Range
Dim FindRow As Range
Set SearchRange = Range("D5", Range("D2000").End(xlUp))
PINamesArray = Split(Me.PINames, "; ")
size = UBound(PINamesArray) - LBound(PINamesArray) + 1
For x = 1 To size
Set FindRow = SearchRange.Find(x, LookIn:=xlValues, LookAt:=xlWhole)
FindRow.Row
RTBM = FindRow.Row
RTBM.Copy
.Paste Worksheets("Dropped-NotSelected").Cells(ERow, 1)
RTBM.Delete Shift:xlShiftUp
End Sub
I want the Find function to look for the item in the delimited list that corresponds to that integer, not the integer itself.
I know that there are probably multiple aspects of this code that aren't right, but I'm having trouble finding good examples to base off of.
Give this a shot - I had to change some variables around (and fix a lot of weird typos you had going on), but this worked in my testing:
Option Explicit
Private Sub CommandButton1_Click()
Dim x As Long, ERow As Long
Dim PINamesArray As Variant
Dim size As Long
Dim SearchRange As Range
Dim FindRow As Long
Set SearchRange = Range("D5:D2000")
ERow = 1
PINamesArray = Split(Me.PINames, "; ")
size = UBound(PINamesArray) - LBound(PINamesArray) + 1
For x = 1 To size
On Error Resume Next
FindRow = SearchRange.Find(What:=PINamesArray(x)).Row
On Error GoTo 0
If FindRow <> 0 Then
Rows(FindRow).Copy
Worksheets("Dropped-NotSelected").Cells(ERow, 1).PasteSpecial
ERow = ERow + 1
Rows(FindRow).Delete Shift:=xlShiftUp
End If
Next x
End Sub
I am writing a small timesaver tool that inserts various text values in a column based on a cell offset of the location of a list-based text search in column C.
Dim C1 As Range
Set C1 = Range("B:B").Find("Value to search")
If C1 Is Nothing Then
Else
C1.Offset(0, -1).Value = "Text value to insert"
End If
I am certain there is a better way to write this relatively simple proc in a more scalable way rather than hard code each value to search in the code, but am not sure how this could be simplified further. I've been looking at the first two lines, and I may be wrong, but I believe a cell range needs to be defined as written in the first two lines in order for the Offset to know the cell location to offset from.
Depends on how you are planning on running this. You could have it as a sub that prompts a user to enter the search value and the text to input at offset. I show that below. It is easy enough instead to adapt to a loop if you have the search and offset strings in the sheet. I use only the populated area of column B for the search. The search values and insert/offset values are held in variables.
Option Explicit
Public Sub AddText()
Dim searchValue As String, insertValue As String, C1 As Range, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
searchValue = Application.InputBox("Please supply search value", Type:=2)
insertValue = Application.InputBox("Please supply insert value", Type:=2)
If searchValue = vbNullString Or insertValue = vbNullString Then Exit Sub 'or loop prompting for entry
With ws
Set C1 = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Find(searchValue)
End With
If Not C1 Is Nothing Then C1.Offset(0, -1).Value = insertValue
End Sub
Edit:
From your comment you are actually just doing a VLOOKUP.
In sheet 2 A1 put the following and autofill down for as many rows as are filled in column B.
=IFERROR(VLOOKUP(B1,Sheet1!A:B,2,FALSE),"")
Same thing using arrays and a dictionary
Option Explicit
Public Sub AddText()
Dim wsSource As Worksheet, wsSearch As Worksheet
Dim lookupArray(), updateArray(), lookupDict As Object, i As Long
Set lookupDict = CreateObject("Scripting.Dictionary")
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsSearch = ThisWorkbook.Worksheets("Sheet2")
With wsSource
lookupArray = .Range("A1:B" & GetLastRow(wsSource, 1)).Value
End With
For i = LBound(lookupArray, 1) To UBound(lookupArray, 1)
lookupDict(lookupArray(i, 1)) = lookupArray(i, 2)
Next
With wsSearch
updateArray = .Range("A1:B" & GetLastRow(wsSearch, 2)).Value
For i = LBound(updateArray, 1) To UBound(updateArray, 1)
If lookupDict.Exists(updateArray(i, 2)) Then
updateArray(i, 1) = lookupDict(updateArray(i, 2))
End If
Next
.Cells(1, 1).Resize(UBound(updateArray, 1), UBound(updateArray, 2)) = updateArray
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
I'm currently writing a program to analyze some data, and my Debugger is throwing the "Duplicate Declaration in Current Scope" error, highlighting "Dim rTickers As Range". I cannot find a duplicate anywhere in here. Is there some other reason I could be getting this error? Thanks for your time.
Sub TSV_Ticker()
'Create Dictionary To get Unique Values From Column A
Dim dTickers As New Dictionary
Dim i As Long
For i = 2 To Rows.Count
On Error Resume Next
dTickers.Add (Cells(i, 1).Value), CStr(Cells(i, 1).Value)
Next
'Create The Ticker And Sum Column Headers
Range("J1").Value = "<Sum>"
Range("I1").Value = "<Ticker>"
'Define where we will be putting our keys
Dim uTickers As Range
Set uTickers = Range("I2")
'Convert Keys into array for syntax reasons
aTickers = dTickers.Keys
'Resize the range so it will fit the array
Set rTickers = rTickers.Resize(UBound(aTickers), 1)
'Put array into range, verticaly
rTickers.Value = Application.Transpose(aTickers)
'Define Range of column A
Dim rTickers As Range
Set rTickers = Range("A2:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row)
Dim TSV As Long
'Defining some Date Variables (Column B)
Dim fDate As Integer
Dim eDate As Integer
Dim rDates As Range
Set rDates = Range("B2:B" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row)
'And The Open / Close Variables (Colums C&F)
Dim vOpen As Double
Dim Vclose As Double
Dim Delta As Double
Dim pDelta As Double
'Adding Some Columns
sht.Range("J1").EntireColumn.Insert
Range("J1").Value = "Yearly Change"
sht.Range("K1").EntireColumn.Insert
Range("K1").Value = "Percent Change"
For Each Cell In rTickers
'Searching our range that we put the Array in for matching Values
Set t = rTickers.Find(Cell.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not t Is Empty Then
'add column G's value to corresponding I value
Cells(t.Row, 10).Value = Cells(t.Row, 10).Value + Cells(Cell.Row, 7).Value
End If
Next Cell
End Sub
As commented, without using Option Explicit variables are created at the first instance.
So in your code, rTickers is already created when this below line is executed:
Set rTickers = rTickers.Resize(UBound(aTickers), 1)
That being said, below line will give you a compile error:
Dim rTickers As Range
because rTickers variable has already been created.
I'll post this as answer for others reference.
But if Rory or Ashlee wish to add their answers, I'll delete mine :).
This is my first time asking for help on any VBA programming sites. I am very new to VBA programming (had some experience 10 years ago) and am trying to create a document cross reference tool for work in which the user can easily search for a document number and see where that document number is referenced in other documents. I am using Excel 2010.
Over the past 3 days scouring websites, and reading Excel VBA programming for dummies (me) a coworker loaned to me, this is the code I have currently written, which successfully comes up with the desired inquiry box, but I can not seem to get the search inquiry to work, or the copy paste commands to work.
I am trying my utmost to be respectful of this site's rules, and demonstrate my efforts at trying to write this code without simply getting someone else to do all the work, but I obviously need help:
Private Sub CommandButton1_Click()
Dim rngCell As Range
Dim ws As Worksheet
Dim lngLstRow As Long
Dim lngLstCol As Long
Dim strSearch As String
Dim r As Long
Dim x As Variant
strSearch = InputBox("Please enter 5 digit document number to search for (e.g. 00002):", "Search Value")
Sheets("DMR").Select
'Loop through sheet DMR and search for "search value". The search value may be in several rows, but will only appear once in a row.
For r = 1 To endRow
x = Range("G3:EP7002").Value 'yes-there are 7002 rows of data all starting at column G and potentially ending at column EP. There are many blank cells.
If Cells(r, x).Value = "Search Value" Then
'Copy the cells at column A and D of found search value row in Sheet "DMR"
Range(Cells(r, "A"), Cells(r, "D")).Select
Selection.Copy
'Switch to sheet "SEARCH" & paste two cells from sheet "DMR" into sheet "SEARCH" cells A5:B5
Sheets("SEARCH").Select
Range(r, "A5:B5").Select
ActiveSheet.Paste
'Next time you find a match in sheet "DMR", it will be pasted in the next row on sheet "SEARCH"
pasteRowIndex = pasteRowIndex + 1
'Switch back to sheet DMR & continue to search for your criteria
Sheets("DMR").Select
End If
Next r
End Sub
If there is anything else I can provide, or some way of conveying the information I am trying to acquire more clearly, please don't hesitate to ask!
Thank-you so much for your patience!
Veronica
This searches the desired range (G3:EP7002) in a loop to find all instances and will drop it in Sheet(Search) starting at A5:B5. It lacks the error checking of user3578951 but I leave you to figure that out ^_^
Private Sub CommandButton1_Click()
Dim dmr As Worksheet
Dim strSearch As String
Dim f As Variant
Dim fAddress As String
Dim fRow As Long
Dim cellA As Variant
Dim cellB As Variant
Set dmr = Worksheets("DMR")
pasteRowIndex = 5
strSearch = InputBox("Please enter 5 digit document number to search for (e.g. 00002):", "Search Value")
With dmr.Range("G3:EP7002")
Set f = .Find(strSearch, LookIn:=xlValues)
If Not f Is Nothing Then
fAddress = f.Address
Do
fRow = f.Row
cellA = dmr.Cells(fRow, 1).Value
cellD = dmr.Cells(fRow, 4).Value
Sheets("SEARCH").Cells(pasteRowIndex, 1) = cellA
Sheets("SEARCH").Cells(pasteRowIndex, 2) = cellD
pasteRowIndex = pasteRowIndex + 1
Set f = .FindNext(f)
Loop While Not f Is Nothing And f.Address <> fAddress
End If
End With
End Sub
Since you're just searching if a value exists, you can shorten that code using the "Find" feature:
Private Sub CommandButton1_Click()
Dim rngCell As Range
Dim dmrWS As Worksheet, searchWS As Worksheet
Dim lngLstRow As Long, strSearchRow As Long, lngLstCol As Long
Dim strSearch As String
Dim r As Long
Dim x As Variant
Dim searchNewRow As Integer
Set dmrWS = Sheets("DMR")
Set searchWS = Sheets("SEARCH")
strSearch = InputBox("Please enter 5 digit document number to search for (e.g. 00002):", "Search Value")
With dmrWS
On Error GoTo ErrorHandler
strSearchRow = .Cells.Find(what:=strSearch, LookAt:=xlWhole).Row
End With
If strSearchRow > 0 Then 'If there was a value found
searchNewRow = searchWS.UsedRange.Rows.Count
With searchWS
.Range(.Cells(searchNewRow, 1), .Cells(searchNewRow, 4)).Value = dmrWS.Range(dmrWS.Cells(strSearchRow, 1), dmrWS.Cells(strSearchRow, 4)).Value
End With
End If
ErrorHandler:
MsgBox (strSearch & " was not found.")
End Sub
I think that does what you want. If the string is found in "DMR" sheet, say on row 9, it'll copy A9:D9 to the next empty row in "Search" sheet. Please let me know if this isn't quite what you're looking for.
Final answer to my request and this works great!
Private Sub CommandButton1_Click()
Dim dmr As Worksheet
Dim strSearch As String
Dim f As Variant
Dim fAddress As String
Dim fRow As Long
Dim cellA As Variant
Dim cellB As Variant
Worksheets("SEARCH").Range("A5:B200").ClearContents
Set dmr = Worksheets("DMR")
pasteRowIndex = 5
strSearch = InputBox("Please enter 5 digit document number to search for (e.g. 00002):", "Search Value")
If strSearch = vbNullString Then
MsgBox ("User canceled, or did not enter a value.")
Exit Sub
End If
With dmr.Range("G3:EP7002")
Set f = .Find(strSearch, LookIn:=xlValues)
If Not f Is Nothing Then
fAddress = f.Address
Do
fRow = f.Row
cellA = dmr.Cells(fRow, 1).Value
cellD = dmr.Cells(fRow, 4).Value
Sheets("SEARCH").Cells(pasteRowIndex, 1) = cellA
Sheets("SEARCH").Cells(pasteRowIndex, 2) = cellD
pasteRowIndex = pasteRowIndex + 1
Set f = .FindNext(f)
Loop While Not f Is Nothing And f.Address <> fAddress
End If
If f Is Nothing Then
MsgBox ("The document number you've entered either does not appear in this tool, or is not cross referenced in any other document.")
Exit Sub
End If
End With
End Sub