I would like to find a match of a date in a column and would like to know the simplest way to do in VBA.
This is what I have tried:
date1 = Sheets("Part2").Cells(i, 1).Value
Dim matchRow As Integer
matchRow = 3
While Sheets("1.A").Cells(matchRow,1).Value != date1 Then
matchRow = matchRow + 1
End While
I am getting a date from another sheet and would like to match it with another sheet.
Need some guidance on how to simplify this.
The following should work - if you set the value for 'i' to get the date to search for...
date1 = Sheets("Part2").Cells(i, 1).value
Sheets("1.A").Select
Cells.Find(What:=date1, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Debug.Print ActiveCell & vbTab & ActiveCell.Address
If ActiveCell = date1 Then
MsgBox "Found in: " & ActiveCell.Address
Else
MsgBox "Not found"
End If
Related
I need to find the last cell that contains data in a row that has blank cells. I have tried:
Dim rowCell as Integer
rowCell = Cells.Find(what:="*", _
after:=Range("A1"), _
lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
matchCase:=False).Column
Debug.Print rowCell
But it returns "5" and the columns go up to HE, which is supposed to be Column 213. How can I get it to return a value for one row?
EDIT:
I was able to get this to work on one row with 158 columns, but when I try it on the line below it, by incrementing the after:=Range("A2"), it gives me 6. It's supposed to be 213. Line 58 goes up to FB, which is supposed to be 158, but the script reports 213.
Figured it out.
Dim rowCell as Integer
For i = 5 To 54
With ActiveSheet
If .Rows(i).EntireRow.Hidden Then
Else
.Rows(i).Select
rowCell = ActiveSheet.Rows(i).Find(what:="*", _
lookat:=xlPart, _
LookIn:=xlFormulas, _
searchorder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Debug.Print "Row " & i; " Column " & rowCell
End If
End With
Next i
Print Last Columns Using the Find Method
Option Explicit
Sub PrintLastColumns()
Dim LastCell As Range
Dim LastColumn As Long
Dim i As Long
For i = 5 To 54
With ActiveSheet.Rows(i)
' Not needed in the Find method (in this case):
' After - refers to the first cell by default.
' LookAt - 'xlWhole' or 'xlPart' is not relevant
' since you search for anything ('*').
' SearchOrder - not relevant when in one row or one column.
' MatchCase - 'False' by default; not relevant ('*').
'Set LastCell = .Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
' or simply:
Set LastCell = .Find("*", , xlFormulas, , , xlPrevious)
End With
If LastCell Is Nothing Then ' no last cell hence no last column
Debug.Print "Row " & i & " is empty."
Else
LastColumn = LastCell.Column
Debug.Print "Row: " & i, "Last Column: " & LastColumn, _
"Last Cell Address: " & LastCell.Address(0, 0)
End If
Next i
End Sub
I am attempting to use variables in what should be a simple addition formula. First I search for the column header in row 3 call "Jan Expense Hours" MsgBox ColL comes back with the letter "I" and MsgBox ColL2 comes back with the letter "J", both of which are correct. lRow comes back with row 55 which is also correct. Although when I try to add these variables to Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'! & [ColL] & 4: & [ColL2] & 4)" I get an Application-defined or object-defined error on this line of code. Does anyone have an Idea what I am doing wrong? Btw, I'm searching for the column header because the columns do shift on various copies.
Full Procedure:
Sub JanTotHrsFind()
Dim lRow As Long
Dim lCol As Long
Dim strSearch As String
Dim aCell As Range
Dim ColL As String
Dim ColL2 As String
Dim ColNo As Long
Sheets("Resource Details").Activate
'find the column
strSearch = "*Jan Expense Hours*"
Set aCell = Sheets("Resource Details").Rows(3).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
'convert column number to letter
ColNo = aCell.Column
ColL = Split(Cells(, ColNo).Address, "$")(1)
ColL2 = Split(Cells(, (ColNo + 1)).Address, "$")(1) 'adds one more column to right
MsgBox ColL
MsgBox ColL2
lRow = Cells.Find(What:="SUBTOTAL*", _
After:=Range(ColL & "4"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row - 1 'minus 1 row to move above
MsgBox "Last Row: " & lRow
'formula for Jan Expense Hours + Jan Capital Hours
'Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'!I4:J4)"
'Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'![" & ColL & "]4:[" & ColL2 & "]4)"
Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'! & [ColL] & 4: & [ColL2] & 4)"
End Sub
You should not write your variables within brackets.
So:
Worksheets("Calcs").Range("F4:F" & lRow).Formula = "=SUM('Resource Details'!" & [ColL] & "4:" & [ColL2] & "4)"
Can you please try your code as I corrected above and see how it goes.
I have two sheets.
Data
Column A Column B Column C Column D Column E
1234
Sheet 1
Cell N3 = 1234
I am using this code to try and find the value in columns A-E.
But for some reason it always returns the wrong result.
Set c = Selection.Find(What:=Worksheets(1).Range("N3").Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Please can someone show me where I am going wrong?
Full Code:
Sub PhoneBook()
'Start Phone Book Directory Code
Dim Contact As String
Dim Email As String
Dim Phone As String
Dim Fax As String
'Start FIND
Dim c As Variant
With Worksheets("Contacts").Range("A2:E10000")
Set c = Selection.Find(What:=Worksheets(1).Range("N3").Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If c Is Nothing Then
'Introduce FailSafe, escape code if no result found
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False
'ActiveSheet.Unprotect Password:="SecretPassword"
Else
'Check values are not blank
If c.Offset(0, 1).Value <> "" Then
Contact = "Contact: " & c.Offset(0, 1).Value & Chr(10)
Else
Contact = "Contact: No Contact Held" & Chr(10)
End If
If c.Offset(0, 2).Value <> "" Then
Email = "Email: " & c.Offset(0, 2).Value & Chr(10)
Else
Email = "Email: No Email Held" & Chr(10)
End If
If c.Offset(0, 3).Value <> "" Then
Phone = "Phone: " & c.Offset(0, 3).Value & Chr(10)
Else
Phone = "Phone: No Phone Held" & Chr(10)
End If
If c.Offset(0, 4).Value <> "" Then
Fax = "Fax: " & c.Offset(0, 4).Value
Else
Fax = "Fax: No Fax Held"
End If
If IsNumeric(c.Value) Then
what_found = c.Offset(0, 1).Value
Else
what_found = c.Value
End If
'Show Contacts
ThisWorkbook.Worksheets("Data").Range("I2").Value = "Hello," & vbNewLine & "Have you tried to contact " & what_found & " about your issue?" & vbNewLine _
& Contact & Email & Phone & Fax
'ThisWorkbook.Worksheets(1).Shapes("Suggest").TextFrame.AutoSize = True
CenterShape ThisWorkbook.Worksheets(1).Shapes("Suggest")
RightShape ThisWorkbook.Worksheets(1).Shapes("Close")
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = True
'Show Close Button
'ThisWorkbook.Worksheets(1).Shapes("Close").OnAction = "HideShape"
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = True
'Protect sheet
'ActiveSheet.Protect Password:="SecretPassword", userinterfaceonly:=True
'ActiveSheet.Shapes("Suggest").Locked = True
End If
End With
End Sub
Public Sub CenterShape(o As Shape)
o.Left = ActiveWindow.VisibleRange(1).Left + (ActiveWindow.VisibleRange.Width / 2 - o.Width / 2)
o.Top = ActiveWindow.VisibleRange(1).Top + (ActiveWindow.VisibleRange.Height / 2 - o.Height / 2)
End Sub
Public Sub RightShape(o As Shape)
o.Left = ThisWorkbook.Worksheets(1).Shapes("Suggest").Left + (ThisWorkbook.Worksheets(1).Shapes("Suggest").Width / 1.01 - o.Width / 1.01)
o.Top = ThisWorkbook.Worksheets(1).Shapes("Suggest").Top + (ThisWorkbook.Worksheets(1).Shapes("Suggest").Height / 30 - o.Height / 30)
End Sub
You need not use selection. it check range only in selection.
if you know the range to be checked as With Worksheets("Contacts").Range("A2:E10000") then
Change the code as shown below
Set c = .Find(What:=Worksheets(1).Range("N3").Value, After:=.Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
As Jeeped suggested, remove the Selection object for your range and instead use the range you defined at the “With” statement. Also, I changed the “After” argument to be a reference to the first cell in the range defined at the “With” statement; and, the “LookIn” argument was changed to be xlValues.
...
With Worksheets("Contacts").Range("A2:E10000")
Set c =.Find(What:=Worksheets(1).Range("N3").Value, After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
...
This search looks at all the columns from A to E. The Find method could return a reference to a cell in a column other than column A if it found a matching value. This may be producing some unusual results for the rest of your code because you are using offset to get the other contact numbers. You may want to consider defining constants for each column and use those with a call to the Cells property using the a constant for the "Column" parameter.
For Example:
Declare your constants for the columns at the beginning of Phonebook().
Const lCOLUMN_EMAIL as long = 3
Use the Cells property for returning values as with the email example below:
If .Cells(c.Row, lCOLUMN_EMAIL).Value <> "" Then
Email = "Email: " & .Cells(c.Row, lCOLUMN_EMAIL).Value & Chr(10)
Else
Email = "Email: No Email Held" & Chr(10)
End If
Limit your search to the A column or which ever column contains the values. (Ignore this part if you want to search all the cells in all the columns.)
Set c = .Columns(1).Find(What:=Worksheets(1).Range("N3").Value, After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False
I cannot find or create VBA code to allow pasting copied text from one cell in another sheet(sheet2) into a previously created comment in another sheet(sheet1).
Here is the code I have successfully compiled thus far, and I am stuck on how to get the text found into the comment box.
Sub For_Reals()
'Add Comment
Sheets("Sheet1").Range("F2").AddComment
Range("F2").Comment.Visible = False
'Find Value in Sheet2 based on Value from Sheet1
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Sheet1").Range("F2").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet2").Range("C:C")
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
Else
MsgBox "Nothing found"
End If
End With
End If
'Copy Value 4 cells to the right of found Value
Selection.Offset(0, 4).Copy
'Need Code to paste copied value in previously created comment
End Sub
Rather than copy and paste the cell value into the comment, you create the text at the same time as creating the comment box. If a comment box already exists an error is raised - so remove any comment boxes in that cell beforehand.
The VBA help gives this as an example:
Worksheets(1).Range("E5").AddComment "Current Sales"
So with this in mind, this code will do the trick:
Sub For_Reals()
'Find Value in Sheet2 based on Value from Sheet1
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Sheet1").Range("F2").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet2").Range("C:C")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'Remove any existing comments, create comment and add text.
If Not Rng Is Nothing Then
Sheets("Sheet1").Range("F2").ClearComments
Sheets("Sheet1").Range("F2").AddComment Rng.Offset(0, 4).Value
Range("F2").Comment.Visible = True
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub
Final code I ended up with is below. Added a loop to run through the column, and added a second reference to pull both the definition and description into the comment. Thank you Darren Bartrup-Cook for helping me out when I was stuck!
Sub Add_Comment_As_Def_Desc_Reference()
'Posted by Jeff Barrett 2015-04-10
Dim FindString1 As String
Dim Rng1 As Range
Dim sCommentText1 As String
Dim sCommentText2 As String
Dim str1 As String
Dim str2 As String
Dim cmmt As String
Dim i As Integer
str1 = "Definition: "
str2 = "Description: "
'Loop Code, must specify range for i based on # of FieldAlias
Sheets("Fields").Select
Range("F4").Select
For i = 4 To 59
'Find Definition & Description in NASDefs based on Value from FieldAlias
FindString1 = ActiveCell.Value
If Trim(FindString1) <> "" Then
With Sheets("NASDefs").Range("C:C")
Set Rng1 = .Find(What:=FindString1, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
End If
'Remove any existing comments, create comment and add text in FieldAlias
If Not Rng1 Is Nothing Then
ActiveCell.ClearComments
sCommentText1 = Rng1.Offset(0, 4).Value
sCommentText2 = Rng1.Offset(0, 5).Value
ActiveCell.AddComment.Text Text:=str1 & Chr(10) & Chr(10) & sCommentText1 & Chr(10) & Chr(10) & str2 & Chr(10) & Chr(10) & sCommentText2
ActiveCell.Comment.Visible = False
ActiveCell.Comment.Shape.AutoShapeType = msoShapeRoundedRectangle
'Format lines of text
With ActiveCell.Comment.Shape.TextFrame
.Characters.Font.ColorIndex = 5
End With
Else
MsgBox "Nothing found"
End If
'End Loop
ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
Next i
'Resize Comment to fit text
'posted by Dana DeLouis 2000-09-16
Dim MyComments As Comment
Dim lArea As Long
For Each MyComments In ActiveSheet.Comments
With MyComments
.Shape.TextFrame.AutoSize = True
If .Shape.Width > 300 Then
lArea = .Shape.Width * .Shape.Height
.Shape.Width = 300
' An adjustment factor of 1.1 seems to work ok.
.Shape.Height = (lArea / 200) * 0.6
End If
End With
Next ' comment
End Sub
Sub Macro1()
Dim cell As Range
Dim MyDay As Integer, MyYear As Integer, MyMonth As Integer
Dim MyDate As Date
MyDate = Format(MyYear & "/" & MyMonth & "/" & MyDay, "dd/mm/yyyy") < --Error
Selection.Formula = ""
Range("M1").Select
Sheets("Case Settled in 2012").Select
Cells.Find(What:=MyDate, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
MsgBox MyDay
End Sub
I want to search the data date=today
MyDate = Format(MyYear & "/" & MyMonth & "/" & MyDay, "dd/mm/yyyy") <--error
What you need is DateSerial
MyDate = DateSerial(MyYear, MyMonth, MyDay)
Also you need to initialize those variables.
EDIT:
I want to search the data date=today
Regarding your 2nd question, #Mehow has already shown you how to loop through a range to do a date comparison in your other question. Do a similar comparison here as well and check if the date matches.