Add Comment on top of existing comment (sendkeys behaviour) - excel

I have a macro that simply enters a comment in a cell. Linked with a hotkey as we use a lot of comments in a specific group file.
The expected outcome:
add a comment, enter date
if there already is a comment in the cell - add a new comment above (also with date)
Issue:
The macro below does everything right, except the sendkeys at the very end. If I enter manually the combination: Ctrl+Home, then End I get exectly where I want in the added comment.
On a comment that writes above the existing comment, I want to be exactly at the end of the date on the top line. As of now, everything works fine, except the curser still end at the bottom
Question:
How do I get the vba inside a comment to behave like keys Ctrl+Home, then End
(tldr: Sendkeys in code does not work inside a comment)
Option Explicit
Sub RPF_Comment()
Dim datum As String, old As String
datum = Format(Now, "dd.mm.yyyy") & ": "
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
On Error GoTo Commentexists
ActiveCell.AddComment ("")
ActiveCell.Comment.Visible = True
ActiveCell.Comment.Shape.Select
With Selection
.Font.Name = "Arial"
.Font.Size = 8
.Font.FontStyle = "Regular"
.Text = datum
End With
Exit Sub
Commentexists:
On Error GoTo out
ActiveCell.Comment.Visible = True
ActiveCell.Comment.Shape.Select
old = Selection.Text
With Selection
.Font.Name = "Arial"
.Font.Size = 8
.Font.FontStyle = "Regular"
.Text = datum & Chr(10) & Chr(10) & old
End With
SendKeys "^{HOME}"
SendKeys "{End}"
out:
End Sub
PS: I know ".select" is not nice. but on a sub this long, 1 select is ok :)

Related

Find/Replace Text from Headers in a Word Document Using VBA in Excel

I am relatively new to VBA coding in Excel. I have adapted this VBA code for my use in order to replace all tagged text with what is in the Excel sheet. This works as intended for the main content in the word document. The only issue I have is that it is not searching/replacing text in the headers of the Word document. Does anyone have any suggestions as to editing the code to find and replace the text in the headers? I am sure it is something simple like defining the right object, but I cannot figure it out. Thank you!
Dim CustRow, CustCol, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp As Object
Dim WordContent, WordHeaderFooter As Word.Range
With Sheet106
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("J3").Value 'Set Template Name
DocLoc = .Range("E" & TemplRow).Value 'Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
CustRow = 4
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
For CustCol = 16 To 180 'Move Through all Columns
TagName = .Cells(3, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol
If .Range("J1").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("Q" & CustRow).Value & _
"_" & .Range("P" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else: 'If Word
FileName = ThisWorkbook.Path & "\" & .Range("Q" & CustRow).Value _
& "_" & .Range("P" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
End With
End Sub
Tim Williams and I both recommended looking at the MVP web page by Jonathan West, Peter Hewitt, Doug Robbins and Greg Maxey. Here is a partial quotation.
This is Word code so you will need tag it to your WordDoc object instead of ActiveDocument.
The complete code to find or replace text anywhere is a bit complex.
Accordingly, let’s take it a step at a time to better illustrate the
process. In many cases the simpler code is sufficient for getting the
job done.
Step 1
The following code loops through each StoryRange in the active
document and replaces the specified .Text with .Replacement.Text:
Sub FindAndReplaceFirstStoryOfEachType()
Dim rngStory As Range
For Each rngStory In ActiveDocument.StoryRanges
With rngStory.Find
.Text = "find text"
.Replacement.Text = "I'm found"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next rngStory
End Sub
(Note for those already familiar with VBA: whereas if you use
Selection.Find, you have to specify all of the Find and Replace
parameters, such as .Forward = True, because the settings are
otherwise taken from the Find and Replace dialog's current settings,
which are “sticky”, this is not necessary if using [Range].Find –
where the parameters use their default values if you don't specify
their values in your code).
The simple macro above has shortcomings. It only acts on the "first"
StoryRange of each of the eleven StoryTypes (i.e., the first header,
the first textbox, and so on). While a document only has one
wdMainTextStory StoryRange, it can have multiple StoryRanges in some
of the other StoryTypes. If, for example, the document contains
sections with un-linked headers and footers, or if it contains
multiple textboxes, there will be multiple StoryRanges for those
StoryTypes and the code will not act upon the second and subsequent
StoryRanges. To even further complicate matters, if your document
contains unlinked headers or footers and one of the headers or footers
are empty then VBA can have trouble "jumping" that empty header or
footer and process subsequent headers and footers.
Step 2
To make sure that the code acts on every StoryRange in each each
StoryType, you need to:
Make use of the NextStoryRange method
Employ a bit of VBA "trickery" as provided by Peter Hewett to bridge any empty unlinked headers and footers.
Public Sub FindReplaceAlmostAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
'Fix the skipped blank Header/Footer problem as provided by Peter Hewett
lngJunk = ActiveDocument.Sections( 1 ).Headers( 1 ).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
With rngStory.Find
.Text = "find text"
.Replacement.Text = "I'm found"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
There is one remaining problem. Just like with the Find and Replace
utility, the code above can miss any text that is contained in one
StoryType/StoryRange nested in a different StoryType/StoryRange. While
this problem does not occur with a nested StoryType/StoryRange in the
wdMainTextStory StoryRange, it does occur in header and footer type
StoryRanges. An example is textbox that is located in a header or
footer.
Step 3
Fortunately Jonathan West provided a work around for the problem of
such nested StoryRanges. The work around makes use of the fact that
Textboxes and other Drawing Shapes are contained in a document’s
ShapeRange collection. We can therefore check the ShapeRange in each
of the six header and footer StoryRanges for the presence of Shapes.
If a Shape is found, we then check each Shape for the presence of the
text, and finally, if the Shape contains text we set our search range
to that Shape's .TextFrame.TextRange.
This final macro contains all of the code to find and replace text
“anywhere” in a document. A few enhancements have been added to make
it easier to apply the desired find and replace text strings.
Note: It is important to convert the code text to plain text before
you paste: if you paste directly from a web browser, spaces are
encoded as non-breaking spaces, which are not "spaces" to VBA and will
cause compile- or run-time errors. Also: Be careful of the long lines
in this code. When you paste this code into the VBA Editor, there
should be NO red visible anywhere in what you pasted. If there is,
try carefully joining the top red line with the one below it (without
deleting any visible characters.
Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim pFindTxt As String
Dim pReplaceTxt As String
Dim lngJunk As Long
Dim oShp As Shape
pFindTxt = InputBox("Enter the text that you want to find." _
, "FIND" )
If pFindTxt = "" Then
MsgBox "Cancelled by User"
Exit Sub
End If
TryAgain:
pReplaceTxt = InputBox( "Enter the replacement." , "REPLACE" )
If pReplaceTxt = "" Then
If MsgBox( "Do you just want to delete the found text?", _
vbYesNoCancel) = vbNo Then
GoTo TryAgain
ElseIf vbCancel Then
MsgBox "Cancelled by User."
Exit Sub
End If
End If
'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections( 1 ).Headers( 1 ).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case rngStory.StoryType
Case 6 , 7 , 8 , 9 , 10 , 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SearchAndReplaceInStory oShp.TextFrame.TextRange, _
pFindTxt, pReplaceTxt
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String , ByVal strReplace As String )
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub

Using a checkmark to add value to a cell

im trying to create a macro for adding text to a field
i want when i click the checkmark to add a specific text to a case
i have 8 checkbox each one will add a different text to the same case
right now my code look like this
Private Sub CheckBox1_Click()
If Me.CheckBox1.Value = True Then
Range("A56").Value = "Test"
Else
Range("A56").Value = " "
End If
End Sub
the problem is if i check 2 checkmark it always replace the text and i want it to add the text not replace it. and also when i uncheck the checkmark it remove everything in the case
the reason why i need it is to save time not having to write them manualy each time
i am very new to excel coding i apreciated any help you guys can give me
thanks a lot for ur time
So the first part:
Range("A56").value = Range("A56").value & " Text"
The second part I'm assuming the real entries are more substantial than "Test" otherwise you might get some false positives, but this should work pretty well:
Private Sub CheckBox1_Click()
With Sheet1 'Change this to the proper sheet codename
If Me.CheckBox1.Value = True Then
.Cells(56, 1).Value = .Cells(56, 1).Value & " Testing"
Else
If InStr(1, .Cells(56, 1).Value, " Testing") Then
Dim splitarr As Variant
splitarr = Split(.Cells(56, 1).Value, " Testing")
Dim element As Variant
.Cells(56, 1).Value = ""
For Each element In splitarr
.Cells(56, 1).Value = .Cells(56, 1).Value & element
Next element
End If
End If
End With
End Sub
You might want to make the entered or deleted string a variable so it is easier to change.

Userform button not working when typing in a textbox vba

I have a userform where you have to enter data into textboxes and then press a button to put the data into the sheet. When I'm typing into the last textbox and I'm done, I click the button and it doesn't respond. Also, I have noticed that my cursor keeps blinking inside the last textbox so I guess there's a problem there (while focused not able to click a button)?
In total I have 4 textboxes, 3 of them use data validation after their value has been updated. The last one does not have data validation.
The weird thing is that, next to the "next button", I have a button to clear the fields and that one works just fine. Below an image from my userform with a little bit of explanation because it's in another language (Dutch). Can anyone help me? Thanks!
The code used for the "next" button is:
Note: the data gets validated not only when they updated the value of the textbox, but also an extra time when they click the next button.
Private Sub AddNextBtn_Click()
AddValueMod.AddDisplayOverview
End Sub
Sub AddDisplayOverview() 'This sub is in the "AddValueMod" module
'Check if information is valid via a function
If AddInformationValid("AccountSelector", True) And AddInformationValid("Date", True) And AddInformationValid("Amount", True) And AddInformationValid("Description", True) Then
'If valid, retrieve entered values
Dim account, dDate, amount, description As String
account = main.AddAccountSelector.Value
dDate = main.AddDateInput.Value
amount = main.AddValue.Value
description = main.AddDescription.Value
'Ask for sheet-writing-confirmation
overview = MsgBox("Kloppen volgende gegevens (kijk goed na!)?" & vbCrLf & vbCrLf & "Rekening: " & account & vbCrLf & "Datum: " & dDate & vbCrLf & "Bedrag: " & amount & vbCrLf & "Beschrijving: " & description & vbCrLf & "Vermeerdering/vermindering: Waarde wordt vermeerderd", vbYesNo + vbQuestion, "Kloppen volgende gegevens?")
If overview = vbYes Then
'Write data to sheet
AddValueMod.AddEnterDataIntoSheet
End If
End If
End Sub
And for the "clear fields" button:
Private Sub AddClearFieldsBtn_Click()
AddValueMod.AddClearFields (True)
End Sub
Sub AddClearFields(askForConfirmation As Boolean) 'This sub is in the "AddValueMod" module
grey = RGB(128, 128, 128)
'If askForConfirmation = True, ask for confirmation before clearing fields
If askForConfirmation = True Then
confirmationMessage = MsgBox("Bent u zeker dat u de velden wilt leegmaken?" + vbCrLf + "U zal terug opnieuw moeten beginnen.", vbYesNo + vbQuestion, "Velden leegmaken?")
If confirmationMessage = vbYes Then
'Clear fields
main.AddAccountSelector.Value = ""
main.AddDateInput.Value = ""
main.AddValue.Value = ""
main.AddDescription.Value = ""
End If
ElseIf askForConfirmation = False Then
'Clear fields
main.AddAccountSelector.Value = ""
main.AddDateInput.Value = ""
main.AddValue.Value = ""
main.AddDescription.Value = ""
End If
'Reset the textboxes' borders (they change if an input error occurred)
main.AddAccountSelectorError.Visible = False
main.AddAccountSelector.BorderStyle = fmBorderStyleSingle
main.AddAccountSelector.BorderColor = grey
main.AddDateInputError.Visible = False
main.AddDateInput.BorderStyle = fmBorderStyleSingle
main.AddDateInput.BorderColor = grey
main.AddValueError.Visible = False
main.AddValue.BorderStyle = fmBorderStyleSingle
main.AddValue.BorderColor = grey
main.AddDescriptionError.Visible = False
main.AddDescription.BorderStyle = fmBorderStyleSingle
main.AddDescription.BorderColor = grey
End Sub
P.S.: I've already tried a possible solution with IsCancel = True/False that I found online in this article. It's possible it didn't work because the article is not quite related to my problem but I felt like I should mention it :).
You did not provide all relevant code. AddInformationValid() and AddEnterDataIntoSheet are missing.
However, if the AddInformationValid() returns False on any item, the behaviour is just as you describe. In AddDisplayOverview() there will be no error message, the AddEnterDataIntoSheet sub will be bypassed and on return from the button handler the cursor remains flashing in the last entry field.
You need to verify and correct the AddInformationValid() Function.
I also strongly recommend to show an error message if the data validation fails.

Copy/Paste Excel cells to Word in loop not working/saving properly

Admittedly new to VBA. I have an excel file that consists of all our part numbers broken down by "-" marks that I wrote code to break down into more descriptive phrases for making labels. I am trying to write code here to loop through different types of part numbers, grab particular cells in that part #'s row and copy/pasting them into a word document and saving the word doc as the part #'s name. As is, it loops but grabs all the info from the different ranges instead of just the info from the same row as part.
The code works (besides saving) if I change the ranges to 1 single cell, but once I have multiple cells in the ranges, it begins copying everything in the range instead of just in the row of the part that it should be looping.
Sub exceltoword2()
Dim part As Range
Dim funct As Range
Dim finish As Range
Dim lever As Range
Dim backset As Range
Dim trim As Range
Set part = Range("A2:A5")
Set funct = Range("Q2:Q5")
Set finish = Range("R2:R5")
Set lever = Range("S2:S5")
Set backset = Range("T2:T5")
Set trim = Range("U2:U5")
Dim wdapp As Word.Application
Set wdapp = New Word.Application
Dim SaveName As String
Dim path As String
path = "C:\Users\bpickett\Desktop\Parts\"
For Each part In part 'Long list of part #'s that will be looped through with particular variables commented out as needed as I adjust range on part variable
With wdapp
.Visible = True
.Documents.Add
.Activate
part.Copy '********************************Part copied
.Selection.PasteSpecial
With .Selection '**********************Function copied
.Font.Name = "Calibri"
.Font.Size = 22
.TypeText "FUNCTION " '7 spaces
End With
funct.Copy
.Selection.PasteSpecial
With .Selection '**************************Finish
.Font.Name = "Calibri"
.Font.Size = 22
.TypeText "FINISH " '14 spaces
End With
finish.Copy
.Selection.PasteSpecial
With .Selection '***************************Backset
.Font.Name = "Calibri"
.Font.Size = 22
.TypeText "BACKSET " '10 spaces
End With
backset.Copy
.Selection.PasteSpecial
ActiveDocument.SaveAs2 path & part & ".docx"
End With
Next
End Sub
The code when ran has the 1st part # correct then, just copies the entire range of Backset/Function/Finish under each instead of just the single cell in the row of the part #.
Took advice from comments above and did a days more worth of research and made some changes that solved all problems.
For i = 1 to 1275
Set part = Range("A" & i)
Set funct = Range("Q" & i)
Set finish = Range("R" & i)
Set lever = Range("S" & i)
Set backset = Range("T" & i)
Set trim = Range("U" & i)
Qualifying the ranges(or at least to me it did) and adding the i array instead of for each part in part was huge for code to loop and grab only necessary information. But when running, it was crashing with error 4605 a lot. But a 7 year old question that was answered on here surrounded the copy/paste commands with labels and error handler
Pg1CopyAttempt:
DoEvents
part.Copy
On Error GoTo Pg1PasteFail
.selection.pastespecial
On Error goto 0 'disable the error handler
Pg1PasteFail:
If Err.Number = 4605 Then ' clipboard is empty or not valid.
DoEvents
Resume Pg1CopyAttempt
End If
Which worked FLAWLESSLY to go through strings of 100's or 1000's of loops(Files created). Just had to modify Pg1 to 2 to 3 and ect through code.

If OptionButton is active TextBox is mandatory

In my UserForm I have several frames, several OptionButtons and several TextBoxes. one example you can see in the screenshot.
Now I want that if I check the medium or high risk OptionButton the TextBox ("- Comment Risk -") should be mandatory and if it is empty or nothin was added an error message should be shown.
This is my macro so far:
Sub Comment_Check()
'obMedium = OptionButton "Medium"
'obHigh = OptionButton "High"
'txtRisk = TextBox "- Comment Risk -"
With UserForm1
For x = 1 to 6
If .Controls("obMedium" & x).Value = True Or .Controls("obHigh" & x).Value = True _
And .Controls("txtRisk" & x).Value = "" Or .Controls("txtRisk" & x).Value = "- Comment Risk -" Then
.Controls("txtRisk" & x).BackColor = RGB(255, 75, 80)
MsgBox "Error Message"
End If
Next
End With
End Sub
Now my problem is, if I check Medium and write something in the risk TextBox, the TextBox will be colored red and the error message is shown. If I check High and write something to the TextBox everything works fine.
What do I have to change that both ways will work.
The main issue is that you have to use parenthesis to group your Or & And satements logically.
Furthermore I suggest the following changes:
Write - Comment Risk - and - Comment Chance - into a Label control above the TextBoxes instead of writing it into the TextBox itself. So the user always can see which is which even when filled with data. Also the code would be easier.
Use a switch ErrorOccured that you turn True in your loop, otherwise you will get 6 error messages in a row (worst case).
Use Option Explicit and declare all your variables properly.
Something like the following should work.
Option Explicit
Sub Comment_Check()
Dim ErrorOccured As Boolean
With UserForm1
Dim x As Long
For x = 1 to 6
If (.Controls("obMedium" & x).Value Or .Controls("obHigh" & x).Value) _
And .Controls("txtRisk" & x).Value = vbNullString Then
.Controls("txtRisk" & x).BackColor = RGB(255, 75, 80)
ErrorOccured = True
End If
Next x
End With
If ErrorOccured Then
MsgBox "Error Message"
End If
End Sub
If you want to turn them non-red in a second run (eg. if you re-check after the user corrected his edit) then add a
ElseIf (.Controls("obMedium" & x).Value Or .Controls("obHigh" & x).Value) And .Controls("txtRisk" & x).Value <> vbNullString Then
.Controls("txtRisk" & x).BackColor = RGB(50, 168, 82) 'green
'don't set ErrorOccured to False here!
right before the End If line otherwise the box will stay red even if the user corrected his edit.

Resources