I am new to both stackoverflow.com and VBA within Excel, so go easy on me :-)
I am looking to have a button in my excel sheet that when clicked, will search the entire or row 1 for a date (located in another cell). If it finds the date in a call in row 1, it will enter some text in the cell below it. If it doesn't find the date, it will add the date to the next free cell in the row and then add the text in the cell below that.
I know I have asked a lot and I am happy to accept partial answers as I know how to do some of the aspect of this. For example the pasting of text and such. The part I am finding difficult is the finding on the date in the entire row 1 and then finding the next blank cell if no date is found.
Any help or pointers will be highly appreciated!
However, I would be even happier if I get a response, the person also explains how the code works as I am very keen to learn VBA and use it again in the future and not just copy and paste.
Thanks in advance for any replies! :-)
Give this a try. I've commented code in details, but if you have some questions, ask in comments:)
Sub test()
Dim ws As Worksheet
Dim rng As Range
Dim targetDate As Range
'change sheet1 to suit
Set ws = ThisWorkbook.Worksheets("Sheet1")
'change address of your cell with target date
Set targetDate = ws.Range("A4")
'tries to find target date in first row
Set rng = ws.Range("1:1").Find(What:=targetDate, LookAt:=xlWhole, MatchCase:=False)
If rng Is Nothing Then
'if nothing found - search for last non empty column
Set rng = ws.Range("1:1").Find(What:="*", LookAt:=xlWhole, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
If rng Is Nothing Then
'if row 1 is empty
Set rng = ws.Range("A1")
Else
'take next column after last non empty
Set rng = rng.Offset(, 1)
End If
'write target date
rng = targetDate
rng.NumberFormat = "dd.mm.yyyy"
'write something below the date
rng.Offset(1) = "test"
Else
'if date is found - write something below the date
rng.Offset(1).Value = "test2"
End If
End Sub
Related
MY EXCEL FILE
Two worksheets: Report and Leaving
One Named Range: Leavers (list of full names in the Leaving worksheet, column A, some names are red and others are orange).
MY GOAL
I want my macro to find in the Report worksheet (specifically in columns G to M) all the names that are part of the Leavers named range and apply the matching font color to each cell that was found.
MY CODE (SO FAR...)
This code could help by searching them one by one but it doesn't change much from doing it manually with Ctrl + F one by one. I could not find another way around it. Feel free to offer better alternatives, codes and solutions.
Dim Sh As Worksheet
Dim Found As Range
Dim Nme As String
Dim Adr1 As String
Nme = Application.InputBox("Enter Name to search", "Test")
Set Sh = Sheets("Sheet1")
With Sh.Range("A2:A")
Set Found = .Find(What:=Nme, After:=.Range("A2"), _
LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not Found Is Nothing Then
Adr1 = Found.Address
Else
MsgBox "Name could not be found"
Exit Sub
End If
Do
Found.Interior.ColorIndex = 4
Set Found = .FindNext(Found)
Loop Until Found Is Nothing Or Found.Address = Adr1
End With
End Sub
Try this:
I tried to stick with some of your existing code but I had to make some changes.
You need to loop through your first range (I've used "G2:M1000" here on Sheet1 which I guess is your report page?)
You can't use a range like "A2:A" in your find routine, so again I've arbitrarily used a 1000 limit: "A2:A1000"
You were using interior cell colour, not font colour, I've changed this but if you did mean interior colour then just swap it back
I'm not using "Exit Sub" since this will stop everything running the first time it encounters a blank cell / no matching name.
Sub eh()
Dim rng As Range: Set rng = Sheet1.Range("G2:M1000")
Dim v As Range
Dim c As Variant
Dim Found As Range
Dim Nme As String
Dim Adr1 As String
For Each v In rng
Nme = v.Value2
If Nme <> "" Then
Set Found = Sheet2.Range("A2:A1000").Find(What:=Nme, After:=Sheet2.Range("A2"), LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not Found Is Nothing Then
v.Font.Color = Found.Font.Color
End If
End If
Next v
End Sub
I tried a different approach, I have a subprocedure to loop through the range of the leavers, and when I find a value i give it to another procedure to look for that value in the report range. I am copying all the format of the cells, you can change it to just copy the font color. Also you should check for the ends of each range, to optimize and also this code would loop several times for the same name if the same name repeats in the leavers range, that could be improved.
Sub select_name() 'Select every cell in the leavers range
Dim leaving_range As Range
Dim row_leaving As Range
Set leaving_range = Sheets("Leaving").Range("A2:A10") 'The leavers list, check for the end of the range
For Each row_leaving In leaving_range.Rows
If row_leaving.Cells(1, 1).Text <> "" Then
row_leaving.Cells(1, 1).Copy 'I am gonna copy all the format, you change it to copy just the font color
Call look_for_name(row_leaving.Cells(1, 1).Text)
End If
Next
End Sub
Sub look_for_name(name_to_find As String) 'look for a name in the report range and change the format
Dim report_range As Range
Dim row_report As Range
Set report_range = Sheets("Report").Range("G1:M5") 'the report range where the names are to be found
For Each row_report In report_range.Rows
For Each cell In row_report.Cells
If cell.Value = name_to_find Then
cell.PasteSpecial Paste:=xlPasteFormats
End If
Next
Next
End Sub
I am still quite new to VBA and decided I would try and teach myself the Range.FindNext method. Unfortunately, I am not very successful so far.
What I am trying to do, is to copy all rows with a specific search term in them to a new sheet (could be anything, therefore declared as a Variant). What is important, is that the search term might only be part of the cell's value, hence I am using xlPart in my Range.Find method.
Here the example data from my ActiveWorkbook.ActiveSheet:
Date Name Numbers
12.04.2012 Marla 45653
13.04.2017 Peter 23545
27.04.1985 Bertrud 46932
16.08.2020 Peterson 46764
15.09.2014 Marcos 32465
21.06.2010 Peter Pan 23452
31.08.2013 Bernard 12321
So, when looking for "Peter", I should be getting rows 3, 5 and 7 in a new sheet. This is the code I wrote for this:
Option Explicit
Dim wsMain, wsNew As Worksheet
Dim rgAll, rgSearchTermFind As Range
Dim varSearchTerm As Variant
Dim lngLastRow, lngLastColumn As Long
Dim firstAddress As String
Public Sub FindAndCopy()
'I have an InputBox for the user to determine the varSearchTerm, but for this example:
varSearchTerm = "Peter"
Set wsMain = ActiveWorkbook.ActiveSheet
Set wsNew = Sheets.Add(After:=Worksheets(Sheets.Count))
Call FindLast(wsMain) 'This is a separate sub I wrote to find the last row & column
With wsMain
Set rgAll = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastColumn))
End With
With rgAll
Set rgSearchTermFind = .Find(What:=varSearchTerm, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlNext, _
MatchCase:=False)
If Not rgSearchTermFind Is Nothing Then
firstAddress = rgSearchTermFind.Address
Do
'Copy row to new sheet
If Application.WorksheetFunction.CountA(wsNew.Cells) <> 0 Then
Call FindLast(wsNew) 'This is a separate sub I wrote to find the last row & column
wsMain.Range(rgSearchTermFind.Address).EntireRow.Copy _
Destination:=wsNew.Cells(lngLastRow + 1, 1)
Else
wsMain.Range(rgSearchTermFind.Address).EntireRow.Copy _
Destination:=wsNew.Cells(1, 1)
End If
'Find next occurrence of search term
Set rgSearchTermFind = .FindNext(rgSearchTermFind)
Loop Until rgSearchTermFind.Address = firstAddress
Else
'Code here to execute if search term could not be found
End If
End With
End Sub
When running this code, the initial Range.Find method finds Peter in B3, but the Range.FindNext then finds "Bertrud" in B4 and copies it. This happens for each cell in the range, leaving me at the end with the table copied three times in the new sheet (due to there being three columns).
What am I doing wrong? Any help will be much appreciated.
I've got a calendar that I'm trying to have populate with userform data in the first blank "appointment slot" upon a button click. An Appointment slot for the date 12/1 would be the cell ranges from E2:J3 then the next appointment slot for the same date is K2:P3 and so on and so forth.
What I'm trying to get it to do is for the next open appointment slot to be filled with the userform data on click of a button.
I.E; Once button is clicked, if date is 12/1 then groupname.text would paste to E2, groupsize.text would paste in F2, lessontime.text would paste in E3...etc. If there's already an appointment in E2:J3 then it would paste in the next apoointment slot; K2 for groupname.text, etc.
It must be based on the date in column D, which the code below can find, but I can't figure out how to use LastRow to loop through the appointment slots to find a blank one. Not to mention how to paste in several different cells and not just ones in the same row.
Help?
If IsDate(DT.Text) Then
Dim thedate As Date
thedate = CDate(DT.Text)
Dim themonth As String
themonth = Format(thedate, "mmm") 'this bit of code is used for another sheet as well
'a bunch of other code for a different task that's happening at the same time.
Dim rng1 As Range
Dim dateStr As String
Dim dateToFind As Date
Dim foundDate As Range
dim cal as worksheet
dim nxtappointment as long
cal = thisworkbook.sheets("calendar")
nxtappointment '= ? this would be the lastrow
dateStr = Format(thedate, ddmm)
dateToFind = DateValue(DT.Text)
Set rng1 = Sheets("Calendar").Range(Cells(4, 1), _
Cells(Rows.Count, 1).End(xlUp))
Set foundDate = rng1.Find(What:=dateToFind, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not foundDate Is Nothing Then
cal.range(E & nxtappointment).value = groupname.text
'etc.
If I understand correctly, there's to things:
Find the first blank slot for an appointment. I usually do something like this. Adapt the column and possibly the offset from last non-empty cell accordingly. For a start this should be good.
Function FindEmptySlotRow(wks As Worksheet) As Long
Dim i As Long
Dim columnToSearch As Integer
columnToSearch = 2 'replace with column index which is always filled for an appointment.
Dim firstEmptyRow As Long
'Search from the bottom of the file in case we have a blank slot in between
For i = wks.UsedRange.Rows.Count To 1 Step -1
If wks.Cells(i, columnToSearch).Value <> vbNullString Then
'we've got a non-empty cell. We just need to know if it's the first or second row of an appoitment slot.
Dim isFirstRowOfAppointment As Boolean
isFirstRowOfAppointment = i Mod 2 = 0 'Your first appointment rows appear to be in odd even rows
If isFirstRowOfAppointment Then
firstEmptyRow = i + 2 '+2 rows - since we found the non-empty cell in first appointment row
Else
firstEmptyRow = i + 1 '+1 row - since we found the non-empty cell in second appointment row
End If
Exit For
End If
Next i
FindEmptySlotRow = firstEmptyRow
End Function
Paste the data. I would do something reusable based on the empty row/cell I find in the previous function. Something in the likes of:
'fill appointment details based on top left cell of appointment
Sub PasteAppointmentData(topLeftAppointmentCell As Range)
'define ranges based on starting cell - EXAMPLE VALUES - adapt to your needs
Dim appointmentNameCell As Range
Dim appointmentTypeCell As Range
appointmentNameCell = topLeftAppointmentCell
appointmentTypeCell = topLeftAppointmentCell.Offset(0, 1)
'define values you want to store and get them from the form - EXAMPLE VALUES - adapt to your needs
Dim appointmentName As String
Dim appointmentType As String
appointmentName = txtboxName.Text
appointmentType = textboxType.Text
'store values in respective ranges
appointmentNameCell.Value = appointmentName
appointmentTypeCell.Value = appointmentType
End Sub
REMARK:
Not sure if I understand correctly, but If you're planning to store multiple appointments for the same day in the same row, I advise against this. Just like I would advise against using 2 rows per appointment. I would suggest a database-like approach. One row per record/appointment with columns that contain appointment properties. That proves beneficial if you want to make some edits/reporting later. Also, it makes your code much easier to write (e.g. no problem of checking for first or second row of appointment anymore).
Hope this helps you get an idea on how to solve this.
I have tried every possible method to search and find the solution to this problem but to no avail, My problem is to search a particular cell value in different sheets in a workbook and copy the entire row along with their headers (Every sheet has different header example, Lab1,Name, Date, Lab Test Type, LabType N, Name, Date, Test Type and so on) and loop through until last value is find with their respective headers. Any help in this regard will be highly appreciated and please forgive me for not knowing the right way to ask the question because i am totally a newbie to this forum.
This code below is giving me the results of the search cell, but because every search result has its own header which i am not getting at the result, as it only pasting the entire row of cell only through loop but not their headers.
Here are the example.
Sheet2 has Name Date Age Sex Cell No Test Type in Range A1:F1
Sheet3 has Name Date Age Sex Cell No Test Type2 Xray Range A1:G1
Sheet4 has Name Date Age Sex Cell No Test Type3 XRay ECG A1:H1
Option Explicit
Option Compare Text '< ignore case
Sub AllRecordSearchMacroForPhone()
Dim FirstAddress As String
Dim c As Range, Sheet As Worksheet
Dim rng As Range
Set rng = Range("D1")
If rng = Empty Then Exit Sub
For Each Sheet In Sheets
If Sheet.Name <> "Sheet1" Then
With Sheet.Columns(5)
Set c = .find(rng, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.EntireRow.Copy _
Destination:=Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Set c = .FindNext(c)
Loop Until c.Address = FirstAddress
End If
End With
End If
Next Sheet
Set c = Nothing
End Sub
Add marked line to your code:
If Not c Is Nothing Then
>>Sheet.Rows(1).Copy Destination:=Sheets("Sheet1").Range("A" & Sheets("Sheet1").Rows.Count).End(xlUp).Offset(1, 0)
FirstAddress = c.Address
I am struggling to find an answer to this one...
Each month I am provided with a spreadsheet full of clients data that is a raw extract from some sort of CRM software and that data is a mess. Some cells are merged, some are not. When you unmerge the whole sheet, you end up with data that is meant for one column randomly spread across 3 columns and mixed with another data, ie email addresses are spread across 3 columns and mixed with postcodes.
What I'd like to be able to do is search for cells within columns S, T and U that contain "#" and move (not copy) the whole email address to column V on the same row.
How can I achieve that?
You can achieve this with the following formula into V1:
=INDEX(S1:U1,MATCH(TRUE,NOT(ISERROR(SEARCH("#",S1:U1))),0))
The formula needs to be entered as array formula, i.e. pressing Ctrl-Shift-Enter.
Press Alt+F11 to open the Visual Basic Editor, and then click Insert, Module. Paste this in. Or, just download the example file here. Then under View/Macros, this movemail() routine will be there. Run it.
I take check, money order, paypal, bitcoin... :-) j/j Enjoy.
Sub moveemail()
Dim ws As Worksheet
Dim thisCell As Range, nextCell As Range, lookAt As Range
Dim foundAt As String, lookFor As String
Dim lastRow As Long
lookFor = "#"
On Error GoTo Err
'get last populated cell
Set ws = Application.ActiveSheet
With ws
If WorksheetFunction.CountA(Cells) > 0 Then
lastRow = Cells.Find(what:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
End With
' go cell by cell looking for # from row 1 to row 10000
Set lookAt = ActiveSheet.Range("S1:U" & lastRow)
Set thisCell = lookAt.Find(what:=lookFor, LookIn:=xlValues, lookAt:=xlPart, SearchDirection:=xlNext)
If Not thisCell Is Nothing Then
Set nextCell = thisCell
Do
Set thisCell = lookAt.FindNext(After:=thisCell)
If Not thisCell Is Nothing Then
foundAt = thisCell.Address
thisCell.Copy Range("V" & thisCell.Row)
thisCell.ClearContents
Else
Exit Do
End If
If thisCell.Address = nextCell.Address Then Exit Do
Loop
Else
'MsgBox SearchString & " not Found"
Exit Sub
End If
Err:
'MsgBox Err.Number
Exit Sub
End Sub