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.
Related
This is about VBA in excel.
I am trying to remove the sign "/" and cut the string length for every cell down to 31 to make those values valid as a name for a new sheet. The constraint is within the first two columns until the last occupied row.
My code compiled, however, it brought me endless processing and I have to task manager-exit every time after running it. Please take a look at it, thank you so much!
Sub replaceSpeCharaAndCutLength()
'selectPositionAndReplaceSpeCharaAndCutLength Macro
Dim cell As Range
Dim row As Long
For row = 7 To Sheet1.Cells(Rows.Count, 1).End(xlUp).row
Worksheets("Sheet1").Columns("A").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
Worksheets("Sheet1").Columns("B").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
For Each cell In Sheet1.Range("A:B").Cells
cell.Value = Left(cell.Value, 31)
Next cell
Next row
End Sub
Updated code 0142 08212020
Sub replaceSpeCharaAndCutLength()
'
' selectPositionAndReplaceSpeCharaAndCutLength Macro
'
Dim cell As Range
Worksheets("Sheet1").Columns("A").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
Worksheets("Sheet1").Columns("B").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
For Each cell In Sheet1.Range("A:B").Cells
cell.Value = Left(cell.Value, 31)
Next cell
End Sub
Range.Replace doesn't require a loop. You can also use Evaluate instead of the other loop:
Sub replaceSpeCharaAndCutLength()
Dim lastRow As Long
lastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Dim rng As Range
Set rng = Sheet1.Range("A7:B" & lastRow)
rng.Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
rng.Value = rng.Parent.Evaluate("INDEX(LEFT(" & rng.Address & ",31),)")
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.
have to replace the word in excel cell .
using like
Sub test()
Dim a_row As String
Dim b_row As String
Dim row_counter As Integer
For row_counter = 1 To 600
a_row = "A" & row_counter
b_row = "B" & row_counter
Dim Findtext As String
Dim Replacetext As String
Findtext = Sheets("sheet1").Range(a_row).Value
Replacetext = Sheets("sheet1").Range(b_row).Value
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ActiveWorkbook.Worksheets(1).Name Then
ws.Cells.Replace What:=Findtext, Replacement:=Replacetext, LookAt:= _
xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End If
Next ws
Next row_counter
End Sub
there are two cols in sheet1. 1st cols shows Japanese words. 2nd column shows English words.
公園 park
夏 summer
緑 Green
青空 blue Sky
男の人 man
In the 2nd sheet displays in col A
column A
公園、夏、青空、緑、男の人
the above code replace Japanese words.
if LookAt:= _xlPart, after replace shows like below
park, summer, 青sky, green,manの人
if LookAt:= _xlWhole , its not replacing the word
In the 2nd sheet displays in the separate columns
A B C D E
公園 夏 青空 緑 男の人
if LookAt:= _xlWhole then
its working perfectly.
i want to do
In the 2nd sheet displays the value in single col A delimited by comma
column A
公園、夏、青空、緑、男の人
need the output like
park, summer, blue sky, green,man
please give some idea.. thanks
Do it in memory instead, it's quicker and much easier to work with arrays. If I understand the way your data is set out - the following should work where your find/replace table is in columns A:B on sheet1 and the values to replace are in sheet2 and are comma separated in cell A1:
Sub MM_Foo()
Dim findArray As Variant
Dim replaceArray As Variant
Dim matchPosition As Long
With Sheets(1)
findArray = .Range("A1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).Value
End With
On Error GoTo checkErr:
For j = 1 To Sheets(2).Cells(Sheets(2).Rows.Count, 1).End(xlUp).Row
replaceArray = Split(Sheets(2).Cells(j, 1).Value, ",")
With Application
For i = LBound(replaceArray) To UBound(replaceArray)
matchPosition = .Match(replaceArray(i), .Index(findArray, , 1), 0)
replaceArray(i) = findArray(matchPosition, 2)
skipReplace:
Next
End With
Sheets(2).Cells(j, 1).Value = Join$(replaceArray, ",")
Next
On Error GoTo 0
Exit Sub
checkErr:
If Err.Number = 13 Then
Err.Clear
GoTo skipReplace:
Else
MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation, "Error"
Err.Clear
On Error GoTo 0
Exit Sub
End If
End Sub
Without a trailing 'comma', there may have to be repetitive passes that may or may not actually do anything; there need to cover all possible combinations.
Sub delimitedTranslate()
Dim w As Long, vWRDs As Variant
With Worksheets("Sheet1")
vWRDs = .Range(.Cells(2, "A"), _
.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1)) _
.Value2
End With
With Worksheets("Sheet2")
With .Columns("A")
For w = LBound(vWRDs, 1) To UBound(vWRDs, 1)
.Replace what:=vWRDs(w, 1) & ChrW(12289), _
replacement:=vWRDs(w, 2) & Chr(44), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
.Replace what:=ChrW(12289) & vWRDs(w, 1), _
replacement:=Chr(44) & vWRDs(w, 2), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
.Replace what:=Chr(44) & vWRDs(w, 1), _
replacement:=Chr(44) & vWRDs(w, 2), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
Next w
End With
End With
End Sub
Sheet1 terms Sheet2 before delimitedTranslate Sheet2 after delimitedTranslate
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
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