Need a find function to search one column of one sheet - excel

I need a find function to search in Column B of my worksheet titled "Quote Sheet" to find "Profit Adjustment" and it would be nice if it was case sensitive. Below is the code I am working with but I can't get the range or the wording correct. Any help is appreciated.
Dim rFound As Range
Set rFound = Range("B10:B1000")
Cells.Find(What:="Profit Adjustment", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Activate
ActiveCell.Offset(0, 8).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sub samPle()
Dim rFound As Range, cellToFind As Range
Set rFound = Sheets("Quote Sheet").Range("B10:B1000")
Set cellToFind = Cells.Find(What:="Profit Adjustment", MatchCase:=True)
If Not cellToFind Is Nothing Then
cellToFind.Activate
ActiveCell.Offset(0, 8).Copy ActiveCell.Offset(0, 8)
End If
End Sub

I would re-write your example like this:
Sub copy_paste_example()
Dim c As Range
With ActiveWorkbook.Sheets("Quote Sheet")
Set c = .Columns("B").Find(What:="Profit Adjustment", _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)
On Error GoTo NotFoundErr:
c.Offset(0, 8).Value = c.Value
End With
Exit Sub
NotFoundErr:
Debug.Print "value not found"
End Sub
Notes:
You weren't ever using the rfound Range Object so I removed it.
Activate and Select are not needed, and may even slow down your code.
Remember that Find returns a Range Object which can be useful later on in your code.

It wasn't immediately clear to me whether you only want to find the first occurrence of Profit Adjustment, or if you care about all occurrences. If you want to find all rows in Column B that contain Profit Adjustment, the below Macro will work as-is. If you want to find only the first occurrence, then simply uncomment the line that says Exit For.
Here's the code:
Sub FindValueInColumn()
Dim rowCount As Integer, currentRow As Integer, columnToSearch As Integer
Dim searchString As String
Dim quoteSheet As Worksheet
Set quoteSheet = ActiveWorkbook.Sheets("Quote Sheet")
searchString = "Profit Adjustment" 'string to look for
columnToSearch = 2 '2 represents column B
rowCount = quoteSheet.Cells(Rows.Count, columnToSearch).End(xlUp).Row
For currentRow = 1 To rowCount
If Not Cells(currentRow, columnToSearch).Find(What:=searchString, MatchCase:=True) Is Nothing Then
Cells(currentRow, 8).Value = Cells(currentRow, columnToSearch).Value
'uncomment the below "Exit For" line if you only care about the first occurrence
'Exit For
End If
Next
End Sub
Before search:
After search:

Related

Selecting a range until the last used row

I am trying to select a range until the last used row in the sheet. I currently have the following:
Sub Select_Active_Down()
Dim lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
If Cells(ActiveCell.Row, ActiveCell.Column) = Cells(lr, ActiveCell.Column) Then
MsgBox "There isn't any data to select."
Else
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(lr, ActiveCell.Column)).Select
Cells(lr, ActiveCell.Column).Activate
End If
End Sub
The issue is that I need to select multiple columns, and this will only select the first column of the active range. How can I modify this to select multiple columns rather than just the first?
What about selection the entire region? This can be done as follows in VBA:
Selection.CurrentRegion.Select
There also is the possibility to select the entire array. For that, just press Ctrl+G, choose Special and see over there.
I would do this slightly different. I would use .Find to find the last row and the last column (using the same logic shown in the link) to construct my range rather than using Selection | Select | ActiveCell | UsedRange | ActiveSheet.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
'~~> Change it to the relevant sheet
Set ws = Sheet1
With ws
'~~> Check if there is data
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "No Data Found"
Exit Sub
End If
'~~> Find last row
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find last column
LastColumn = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Construct your range
Set rng = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
'~~> Work with the range
With rng
MsgBox .Address
'
'~~> Do what you want with the range here
'
End With
End With
End Sub

Find a value in range + loop

I need my macro to Look at a cell in my range, Find that value in the a different WS and paste a value on to that's next to the value i'm looking for (my original WS). do this again and again to the values in the range.
now it all works but for some reason the value is stuck on the first search and wont look for other values in the original range.
here is my code, and the pictures should help.
Sub Macro1()
'
'now im gonna match the "UDD" TO THE "S/O"
Worksheets("Sheet1").Activate
Range("c17").Select
Dim Searchkey As Range, cell As Range
Set Searchkey = Range("c17:c160")
For Each cell In Searchkey
Sheets("data").Activate
Cells.Find(What:=Searchkey, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, -1).Range("A1").Select
Selection.Copy
Next cell
End Sub
why is my macro stuck on "84225" and not looping to the other S/O?
Thank you
Sub mac1()
Worksheets("Sheet1").Activate
Range("c17").Select
Dim srch As Range, cell As Variant
Set srch = Range("c17:c160")
For Each cell In srch
Sheets("data").Activate
Cells.Find(What:=cell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Activate
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, -1).Range("A1").Select
Selection.Copy
Next cell
End Sub
this is working!
thank you all
On each loop you're searching for the whole range of SearchKey and not just Cell so I'm guessing it's always using the first cell in SearchKey as your search criteria.
You're also searching in the formula rather than the values, and looking for a part match which may return incorrect results (part match on 20 would return a find in 20, 201, 11120001, etc).
Not qualifying your sheet names and using Activate probably isn't helping much either.
Try this code:
Public Sub Test()
Dim SrcSht As Worksheet, TgtSht As Worksheet
Dim SearchKey As Range, Cell As Range
Dim FoundValue As Range
With ThisWorkbook
Set SrcSht = .Worksheets("Sheet1")
Set TgtSht = .Worksheets("Data")
End With
Set SearchKey = SrcSht.Range("C17:C21")
For Each Cell In SearchKey
'Search column 3 (C) for your the value
Set FoundValue = TgtSht.Columns(3).Find(What:=Cell, _
After:=TgtSht.Columns(3).Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
'Only proceed if value found, otherwise an error will occur.
If Not FoundValue Is Nothing Then
Cell.Offset(, 1) = FoundValue.Offset(, 1)
End If
Next Cell
End Sub
Edit:
To test the code place the cursor within the procedure and press F8 to process each line in turn. The FoundValue should contain a value each time it's executed.
To check this hover your cursor over the variable to see its value:
The row highlighted in yellow is the next line that will be executed. If FoundValue is nothing then the following line isn't processed, if it's not nothing then the line is executed.

Find cell with value, offset and copy range then paste basing data's date, then loop to findnext

With th following Excel Sheet.
I'm trying to do the following:
Find the cell with Value, let's say "Sam", in range("B17:B25")
Offset(0,5).resize(,8).copy
Find the Date value of the Data row, and paste Data to range("B4:M4") according to the data's Date.
Loop to find next.
Here is what I got so far, don't know how to loop:
Sub getDat()
Dim myFind As Range
Dim pasteLoc As Range
Dim payee, pasteMon As String
Range("B5:M12").ClearContents
With Sheet3.Cells
payee = Range("B2").Text
Set myFind = .Find(What:=payee, After:=Range("B16"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not myFind Is Nothing Then
myFind.Offset(0, 3).Resize(, 8).Copy
pasteMon = myFind.Offset(0, 1).Text
With Range("B4:M4")
Set pasteLoc = .Find(What:=pasteMon, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not pasteLoc Is Nothing Then
pasteLoc.Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
End If
End With
End If
End With
End Sub
Here is simplified version (not tested)
Sub getDat()
Range("B5:M12").ClearContents
Dim c As Range, r As Range
For Each c in Range("B16").CurrentRegion.Columns(1).Cells
If c = Range("B2") Then
Set r = Range("B4:M4").Find(c(, 2))
If Not r Is Nothing Then
r(2).Resize(8) = Application.Transpose(c(, 4).Resize(, 8))
End If
End If
Next
End Sub
Something like this For loop would work as well:
Sub getDat()
Dim payee As String
Dim lastrow As Long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
payee = Range("B2").Value
Range("B5:M12").ClearContents
For x = 17 To lastrow
If Cells(x, 2).Value = payee Then
For y = 2 To 13
If Cells(4, y).Value = Cells(x, 3).Value Then
Range("E" & x & ":L" & x).Copy
ActiveSheet.Range(Cells(5, y), Cells(12, y)).PasteSpecial Transpose:=True
Exit For
End If
Next y
End If
Next x
End Sub

Cleaner way of "finding" a range of values

So I currently a macro that assigns a cell value to a variable and then search for this variable on a another sheet. The problem is that I am having to do this a large number values so I currently have the same code copied 20 times allowing for 20 values to be search in series. Is there a cleaner method of running a repeatable operation like this? Also is it possible to set the upper limit based on the number of values entered. E.g. my current setup looks cells M8:M27 for it's variables, is it possible however to write it so that it is repeated continuously until it hits a blank cell? Thereby letting the user enter as many values as required?
Here is an extract for a single variable. This is then repeated up to reverse_id_20
Sheets("GR Input").Select
reverse_id_1 = Range("O8")
Sheets("PchOrds").Select
Columns("A:A").Select
Selection.Find(What:=reverse_id_1, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Select
Rows(ActiveCell.Row).Select
Selection.Delete Shift:=xlUp
Sheets("GR Input").Select
Thanks in advance guys,
Dan
Is there a cleaner method of running a repeatable operation like this?
Yes, it is. You can use loop for it:
Sub test()
Dim reverse_id As Variant
Dim rng As Range
Dim r_id As Variant
With Sheets("GR Input")
reverse_id = .Range("O8:O11")
End With
For Each r_id In reverse_id
Set rng = Sheets("PchOrds").Columns("A:A").Find( _
What:=r_id, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False)
If Not rng Is Nothing Then
rng.EntireRow.Delete Shift:=xlUp
End If
Next r_id
End Sub
Btw, code above deletes only first row that meet criteria. If you'd like to delete all values from sheet "PchOrds", that meet criteria, use this code:
Sub test1()
Dim reverse_id As Variant
Dim rng As Range
Dim lastrow As Long
Dim r_id As Variant
With Sheets("GR Input")
reverse_id = .Range("O8:O11")
End With
For Each r_id In reverse_id
If r_id <> "" Then
With Sheets("PchOrds")
lastrow = Application.Max(2, .Cells(.Rows.Count, "A").End(xlUp).Row)
.AutoFilterMode = False
With .Range("A1:A" & lastrow)
.AutoFilter Field:=1, Criteria1:="=*" & r_id & "*"
.Offset(1, 0).Resize(lastrow - 1, 1).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End If
Next r_id
End Sub

If field has an X, copy cell to another sheet

I have an Excel tracker that I put an "X" in a cell every month if a certain activity is accomplished.
This "X" correlates to a range of cells on the same sheet.
I want when I click on a command box;
If the cell for January has an "X" copy specific cells on the current page to specific cells on another work sheet.
If the cell for February has an "X" copy some other specific cells on the current page to some other specific cells on the other worksheet.
So on and so forth through December.
I have the following code (which does not work):
Private Sub CommandButton1_Click()
Sheets("MRT").Select
If InStr(1, (Range("L8").Value), "X") > 0 Then
Range("E42:AA42").Select
Selection.Copy
Sheets("Test '12").Select
Cells(3, AP).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone
End If
End Sub
Try this:
Private Sub CommandButton1_Click()
If Sheets("MRT").Range("L8").Value like "*X*" Then
Sheets("MRT").Range("E42:AA42").Copy
Sheets("Test '12").Cells(3, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
End If
End Sub
Worked in my test, however you might want to adapt Cells(3,1) and the other position specifiers to your desired targets.
edit: forgot about the part with the months ... wait a minute ... here:
Sub FindSignificant()
Dim SearchString As String
Dim SearchRange As Range, cl As Range
Dim FirstFound As String
Dim sh As Worksheet
' Set Search value
SearchString = "a"
Application.FindFormat.Clear
' loop through all sheets
Set sh = Sheets("MRT")
' Find first instance on sheet
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cl Is Nothing Then
' if found, remember location
FirstFound = cl.Address
' format found cell
Do
Select Case sh.Cells(cl.Row, 1).Value
Case "december"
sh.Range("E42:AA42").Copy
Sheets("Test '12").Cells(3, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Case "february"
sh.Range("E42:AA42").Copy
Sheets("Test '12").Cells(3, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Case Else
'do nothing
End Select
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
End If
End Sub
this code origins from here
You would have to adapt the select case, but i really would think about solving this without VBA, if it is not necessary ;)

Resources