Excel VBA Comment Query - vba

So I have tried and failed many times to do this.
I'm trying to write a VBA script that when run will insert a comment in the active cell that says:
[Surname], [First Name]
[Todays date] was [current cell value]
Surnames and First Names should be bold.
If the cell is edited again it would edit the comment and put the above format below the previous comment.
Here is what I have at the moment (bearing in mind it could be very wrong)
Sub Test()
Dim UserN As String
Dim commt As String
Dim cmt As Comment
UserN = Application.UserName
Set cmt = ActiveCell.Comment
If ActiveCell.Comment Is Nothing Then
commt = UserN & Chr(10) & Chr(10) _
& Chr(10) & Format(Now, strDate) & " was £" & ActiveCell
With Selection
With Cells(Selection.Row, Selection.Column)
.ClearComments
.AddComment
.Comment.Visible = False
.Comment.Shape.AutoShapeType = msoShapeRoundedRectangle
.Comment.Text Text:=commt
With .Comment.Shape.TextFrame
' Username
With .Characters(1, Len(UserN)).Font
.Bold = True
End With
With .Characters.Font
.Size = 12
End With
End With
.Comment.Shape.TextFrame.AutoSize = True
End With
End With
Else
commt.txt = commt.txt & Chr(10) UserN & Chr(10) & Chr(10)
& Chr(10) & Format(Now, strDate) & " was £" & ActiveCell
With Selection
With Cells(Selection.Row, Selection.Column)
.ClearComments
.AddComment
.Comment.Visible = False
.Comment.Shape.AutoShapeType = msoShapeRoundedRectangle
.Comment.Text Text:=commt
With .Comment.Shape.TextFrame
' Username
With .Characters(1, Len(UserN)).Font
.Bold = True
End With
With .Characters.Font
.Size = 12
End With
End With
.Comment.Shape.TextFrame.AutoSize = True
End With
End With
End If
End Sub

I think the only major issue is with this line:
commt.txt = commt.txt & Chr(10) UserN & Chr(10) & Chr(10)
& Chr(10) & Format(Now, strDate) & " was £" & ActiveCell
It is using the variable 'commt' as if it were a comment object, but is simply a string. It's also missing a '&' and a '_' line separator. I believe the line should be:
commt = cmt.text & Chr(10) & UserN & Chr(10) & Chr(10) & Chr(10) & Format(Now, strDate) & " was £" & ActiveCell

Related

If Then to un-protect and protect document

I have a userform that unprotects a document to let info be entered then protects the document. All of my subs work aside one.
Ranges with if/thens don't work but basic if then works.
Example of sub that works:
Private Sub ComboBox5_Change()
ActiveDocument.Unprotect "password"
Dim ComboBox5 As Range
Set ComboBox5 = ActiveDocument.Bookmarks("bmragpd").Range
ComboBox5.Text = Me.ComboBox5.Value
If Me.ComboBox5.Value = "No" Then
ComboBox5.Text = "205.55a"
End If
If Me.ComboBox5.Value = "Yes" Then
ComboBox5.Text = ""
End If
ActiveDocument.Protect wdAllowOnlyFormFields, NoReset:=True, Password:="password"
End Sub
This sub will say the document is already unprotected.
I tried removing the unprotect on combobox6:
Private Sub ComboBox6_Change()
ActiveDocument.Unprotect "password"
Dim rngComboBox6 As Range
Dim sssaText As String
Dim iiia As Integer
Set rngComboBox6 = ActiveDocument.Bookmarks("bmfcs").Range
sssaText = ComboBox6.Value
If Me.ComboBox6.Value = "Yes" Then
For iiia = 1 To 1
sssaText = sssaText & Chr(13) & "200" _
& Chr(13) & "200.1" _
& Chr(13) & "" _
& Chr(13) & "OEBS" _
& Chr(13) & "" _
& Chr(13) & "21c" _
& Chr(13) & "" _
& Chr(13) & "22c" _
& Chr(13) & "Yes" _
& Chr(13) & "" _
& Chr(13) & "Yes" _
& Chr(13) & "Two" _
& Chr(13) & "" _
& Chr(13) & "ES2a.1" _
& Chr(13) & "" _
& Chr(13) & "222" _
& Chr(13) & "" _
& Chr(13) & "222a" _
& Chr(13) & "222b" _
& Chr(13) & "" _
& Chr(13) & "3.a.1" _
& Chr(13) & "" _
& Chr(13) & "NA" _
& Chr(13) & "" _
& Chr(13) & "I. TuuVa"
Next iiia
sssaText = sssaText & Chr(13) & "717217" _
& Chr(13) & "" _
& Chr(13) & "1212" _
& Chr(13) & "" _
& Chr(13) & "D.1" _
& Chr(13) & "F2B-4"
End If
rngComboBox6.Text = sssaText
ActiveDocument.Bookmarks.Add "bmfcs", rngComboBox6
If Me.ComboBox6.Value = "No" Then
ComboBox6.Text = ""
End If
ActiveDocument.Protect wdAllowOnlyFormFields, NoReset:=True, Password:="password"
End Sub
The first End If is in the wrong place. You are adding text to the document regardless of the value of the combo box.
It is not good practice to use a control’s change event to commit changes to a document. Apart from anything else it doesn’t allow the user to cancel without making changes.
Instead use an OK/Apply/Finish button.
Then you only need to unprotect/reprotect the document once.

how do i move this sub from sheet 1 to sheet 2

I need to move this search to a userform that currently performs a search on sheet 1 I would like to put the database on sheet 2, everything works but the insert function cannot find the last row.
Private Sub ComboBox1_Change()
Dim Riga As Long
If ComboBox1.Value <> "" Then
Riga = ComboBox1.ListIndex + 2
Cells(Riga, 1).Select
TextBox1 = ComboBox1.Value
TextBox2 = Sheets(2).Cells(ActiveCell.Row, 2)
TextBox3 = Sheets(2).Cells(ActiveCell.Row, 3)
TextBox4 = Sheets(2).Cells(ActiveCell.Row, 4)
TextBox5 = Sheets(2).Cells(ActiveCell.Row, 5)
TextBox6 = Sheets(2).Cells(ActiveCell.Row, 6)
End If
End Sub
Private Sub CommandButton_Chiudi_Click()
Unload Me
End Sub
Private Sub CommandButton_Nuovo_Click()
Dim tx As Byte
ComboBox1.Value = ""
Cells(Range("A1").End(xlDown).Row + 1, 1).Select
For tx = 1 To 6
Userform1.Controls("TextBox" & tx).Text = ""
Next tx
TextBox1.SetFocus
End Sub
Private Sub CommandButton_Cancella_Click()
Dim Messaggio As String, Stile As String, Titolo As String
Dim Risposta As VbMsgBoxResult
Titolo = "Cancellazione Record."
Messaggio = "Vuoi cancellare il tesserino:" & Chr(10) & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 1) & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 2) & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 3) & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 4) & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 5) & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 6) & Chr(10)
Stile = vbYesNo + vbQuestion + vbDefaultButton2
Risposta = MsgBox(Messaggio, Stile, Titolo)
If Risposta = vbNo Then End
ActiveCell.EntireRow.Delete
End
End Sub
Private Sub CommandButton_Aggiorna_Click()
Dim Riga As Long
Dim Messaggio As String, Stile As String, Titolo As String
Dim Risposta As VbMsgBoxResult
Titolo = "Cancellazione Record."
Messaggio = "Vuoi registrare il tesserino:" & Chr(10) & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 1).Value & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 2).Value & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 3).Value & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 4).Value & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 5).Value & Chr(10) _
& Sheets(2).Cells(ActiveCell.Row, 6).Value & Chr(10) & Chr(10) _
& "con:" & Chr(10) _
& TextBox1.Value & Chr(10) _
& TextBox2.Value & Chr(10) _
& TextBox3.Value & Chr(10) _
& TextBox4.Value & Chr(10) _
& TextBox5.Value & Chr(10) _
& TextBox6.Value
Stile = vbYesNo + vbQuestion + vbDefaultButton2
Risposta = MsgBox(Messaggio, Stile, Titolo)
If Risposta = vbNo Then End
Riga = ActiveCell.Row
ComboBox1.Value = ""
Sheets(2).Cells(Riga, 1) = TextBox1.Value
Sheets(2).Cells(Riga, 2) = TextBox2.Value
Sheets(2).Cells(Riga, 3) = TextBox3.Value
Sheets(2).Cells(Riga, 4) = TextBox4.Value
Sheets(2).Cells(Riga, 5) = TextBox5.Value
Sheets(2).Cells(Riga, 6) = TextBox6.Value
ComboBox1.SetFocus
End Sub
how can I do to indicate that with the insert new record function I find the last row on the database that I have moved to sheet 2? thank you
sheets(2).Cells(Range("A1").End(xlDown).Row + 1, 1).Select
it doesn't work and I go into error
There are two easy methods. Try them out use what ever works fine for your case.
Method 1:
Sheets(2).UsedRange.Rows.Count
Method 2:
Sheets(2).Cells(Rows.Count, col_no).End(xlUp).Row
Here you need to change col_no to your desired column. For the above example it would be like
Method 2:
Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
These both method will give you last data containing row you need to add one ( +1 ) to get next blank row for new data entry.

How to scrape web data in vba

I have followed jsotola's suggestion and recorded the following macro, but encountered an error, how can I solve it?
Run time error 91 and the following code has been highlighted
Selection.ListObject.TableObject.Refresh
Sub Macro1()
ActiveWorkbook.Queries.Add Name:="1-1-1", Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Source = Web.Page(Web.Contents(""http://www.hkjc.com/English/racing/Horse.asp?HorseNo=V099""))," & Chr(13) & "" & Chr(10) & " Data0 = Source{0}[Data]," & Chr(13) & "" & Chr(10) & " #""Changed Type"" = Table.TransformColumnTypes(Data0,{{""Column1"", type text}, {""Column2"", type text}, {""Column3"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Changed Type"""
ActiveWorkbook.Queries.Add Name:="1-1-2", Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Source = Web.Page(Web.Contents(""http://www.hkjc.com/English/racing/Horse.asp?HorseNo=V099""))," & Chr(13) & "" & Chr(10) & " Data1 = Source{1}[Data]," & Chr(13) & "" & Chr(10) & " #""Changed Type"" = Table.TransformColumnTypes(Data1,{{""Column1"", type text}, {""Column2"", type text}, {""Column3"", type text}, {""Column4"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Changed Type"""
Workbooks("Book1").Connections.Add2 "Query - Table 0", _
"Connection to the 'Table 0' query in the workbook.", _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=Table 0" _
, """Table 0""", 6, True, False
Workbooks("Book1").Connections.Add2 "Query - Table 1", _
"Connection to the 'Table 1' query in the workbook.", _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=Table 1" _
, """Table 1""", 6, True, False
Sheets.Add After:=ActiveSheet
Selection.ListObject.TableObject.Refresh
Sheets.Add After:=ActiveSheet
Selection.ListObject.TableObject.Refresh
End Sub
You could use the following script.
① I grab the left hand side links with
.getElementsByTagName("table")(3).getElementsByTagName("a")
As these return relative paths starting with "about:", I replace this part with the fixed prefix string BASESTRING. This gives the absolute path.
② I target the table with main info by getting get a collection of the table tags and selecting the appropriate table by index.
Set hTable = .getElementsByTagName("table")(6)
③ Additionally, as targeting by className is not supported with method I am using, due to late bound HTMLfile I assume), I parse the sub header out "SMART BOY (V076)" from the innerHTML of an element containing this info. Otherwise, it could have been targeted more cleanly with .getElementsByClassName("subsubheader")(0)
Example data on page:
Example output from code:
Code:
Option Explicit
Public Sub GetTable()
Dim sResponse As String, hTable As Object
Application.ScreenUpdating = False
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "http://www.hkjc.com/english/racing/horse.asp?HorseNo=V076", False
.send
sResponse = StrConv(.responseBody, vbUnicode)
End With
sResponse = Mid$(sResponse, InStr(1, sResponse, "HEAD"))
With CreateObject("htmlFile")
.Write sResponse
Set hTable = .getElementsByTagName("table")(6)
Dim links As Object, title As String
Set links = .getElementsByTagName("table")(3).getElementsByTagName("a")
title = Replace$(Split(Split(.getElementsByTagName("table")(2).innerHTML, "title_eng_text>")(1), "<")(0), " ", vbNullString)
End With
Dim tSection As Object, tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Long, hBody As Object
Set hBody = hTable.getElementsByTagName("tbody")
Const BASESTRING As String = "http://www.hkjc.com/english/racing/"
With ActiveSheet
.Cells(1, 1) = title
r = 2
For Each tSection In hBody 'HTMLTableSection
Set tRow = tSection.getElementsByTagName("tr") 'HTMLTableRow
For Each tr In tRow
Set tCell = tr.getElementsByTagName("td")
c = 1
.Cells(r, c) = links(r - 1).innerHTML
.Cells(r, c + 1) = Replace$(links(r - 1), "about:", BASESTRING)
For Each td In tCell 'DispHTMLElementCollection
.Cells(r, c + 2).Value = td.innerText 'HTMLTableCell
c = c + 1
Next td
r = r + 1
Next tr
Next tSection
.UsedRange.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

VBA using multiple Application.OnTime; one seems to fail

This is part of a much larger macro that has multiple instances of Application.OnTime that work just fine.
My issue with this one below is in WaitForPriceVolume() when it gets to the For Each loop and the If is true, it doesn't go back to the procedure WaitForPriceVolume(). It circles back to all the procedures that were called before, effectively just doing the Exit Sub as if the OnTime didn't exist.
When I strip out just the below code and add fixed values for the global variables being used, the Application.OnTime works. It's only when I plug it back into the bigger macro.
Sub BDP_PriceVolume()
Dim lsStartRange As String
Dim lsEndRange As String
Dim lnStartRow As Long
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Set sht = Worksheets("Variables")
' Use gvList
lsStartRange = "C" & gnStartRow
lnStartRow = gnStartRow + UBound(gvList, 2)
lsEndRange = "C" & lnStartRow
sht.Range(lsStartRange & ":" & lsEndRange).Value = _
"=BDP($A" & gnStartRow & "&Variables!$A$2,Variables!$D$2)"
lsStartRange = "D" & gnStartRow
lsEndRange = "D" & lnStartRow
If Worksheets("Variables").Cells(3, 3).Value <> "" Then
sht.Range(lsStartRange & ":" & lsEndRange).Value = _
"=BDH($A" & gnStartRow & "&Variables!$A$2,Variables!$E$3" & "," & _
"Variables!$B$4,Variables!$C$3," & _
Chr(34) & "BarTp=T" & Chr(34) & "," & _
Chr(34) & "BarSz=40" & Chr(34) & "," & _
Chr(34) & "Dir=V" & Chr(34) & "," & _
Chr(34) & "Dts=H" & Chr(34) & "," & _
Chr(34) & "Sort=A" & Chr(34) & "," & _
Chr(34) & "Quote=C" & Chr(34) & "," & _
Chr(34) & "UseDPDF=Y" & Chr(34) & ")"
Else
sht.Range(lsStartRange & ":" & lsEndRange).Value = _
"=BDP($A" & gnStartRow & "&Variables!$A$2,Variables!$E$2)"
End If
sht.Range("C" & gnStartRow & ":" & lsEndRange).Select
Application.Run "RefreshCurrentSelection"
Application.OnTime Now + TimeValue("00:00:03"), "WaitForPriceVolume"
End Sub
Private Sub WaitForPriceVolume()
Dim rng As Range
Set rng = sht.Range("C" & gnStartRow & ":D" & fnLastRow(sht, "A"))
Dim cell As Range
Application.ScreenUpdating = True
For Each cell In rng
If cell.Value = "#N/A Requesting Data..." Then
Application.OnTime Now + TimeValue("00:00:03"), "WaitForPriceVolume"
Exit Sub
End If
Next cell
Call DoneWaitForPriceVolume
End Sub
Own stupidity. All the other instances of OnTime came at the end of the code, so the macro had nothing left to do until the OnTime triggered and I forced everything to circle back to the main macro. I hadn't done that in this case. Problem solved. This haunted me for a week

Excel Header Macro maxes out at 3 lines

This macro is to set a four line left header for all the worksheets in the workbook. The point of this macro is to have control of each line's font size, and attribute i.e bold. I have a separate sheet called header that has the values I use. It will work for 3 lines, but when I add the fourth it bugs out.
I get this error.
Run-time error '1004':
Unable to set the LeftHeader property of the PageSetup class
Also note I am running Excel 2010 64 bit.
Sub Header()
'
' Header Macro
'
lHeader = "&""Calibri,Regular""&10" & Worksheets("Header").Range("B2").Value
lHeader = lHeader & Chr(13) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B3").Value
lHeader = lHeader & Chr(13) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B4").Value
lHeader = lHeader & Chr(13) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B5").Value
Dim Naam As String, NameFile() As String
ReDim NameFile(1 To Sheets.Count)
With Application
.ScreenUpdating = False
i = 1
For Each shtNext In Sheets
With Sheets(i).PageSetup
.LeftHeader = lHeader
.LeftFooter = Format(Now, "mmmm d, yyyy")
.CenterFooter = "&""Calibri,Regular""&10" & Format(Worksheets("Header").Range("C8").Value)
.RightFooter = "&""Calibri,Regular""&10" & Format(Worksheets("Header").Range("D8").Value) & "&p of &N"
End With
i = i + 1
Next shtNext
End With
End Sub
You are getting that error because you are exceeding the 255 character limit. Unfortunately I couldn't find an MSDN article to back it up but it can be easily re-produced.
The current lengths that you have is
HeaderL - 121
HeaderC - 112
HeaderR - 121
Total - 354
Try this code. Here you can experiment it to reduce the characters.
Sub Header()
HeaderL = "&""Calibri,Regular""&10" & Worksheets("Header").Range("B2").Value
HeaderL = HeaderL & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B3").Value
HeaderL = HeaderL & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B4").Value
HeaderL = HeaderL & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("B5").Value
HeaderC = "&""Calibri,Bold""&14" & Worksheets("Header").Range("C2").Value
HeaderC = HeaderC & Chr(10) & "&""Calibri,Bold""&14" & Worksheets("Header").Range("C3").Value
HeaderC = HeaderC & Chr(10) & "&""Calibri,Bold""&14" & Worksheets("Header").Range("C4").Value
HeaderC = HeaderC & Chr(10) & "&""Calibri,Regular""&14" & Worksheets("Header").Range("B5").Value
HeaderR = "&""Calibri,Regular""&10" & Worksheets("Header").Range("D2").Value
HeaderR = HeaderR & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("D3").Value
HeaderR = HeaderR & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("D4").Value
HeaderR = HeaderR & Chr(10) & "&""Calibri,Regular""&10" & Worksheets("Header").Range("D5").Value
If Len(HeaderL) + Len(HeaderC) + Len(HeaderR) > 255 Then
MsgBox "Oops, You have exceeded the character limit. Please reduce it and try again"
Exit Sub
End If
Dim ws As WorkSheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Sheets
With ws.PageSetup
.LeftHeader = HeaderL
.CenterHeader = HeaderC
.RightHeader = HeaderR
.LeftFooter = Format(Now, "mmmm d, yyyy")
.CenterFooter = "&""Calibri,Regular""&10" & Format(Worksheets("Header").Range("C8").Value)
.RightFooter = "&""Calibri,Regular""&10" & Format(Worksheets("Header").Range("D8").Value) & "&p of &N"
End With
Next ws
Application.ScreenUpdating = True
End Sub
The 255 character limit is for real, even when separating the macros. The font values are a big part of the total. So I removed them all execpt the last line. But If I ever need a report that has different font sizes. I have a little wiggle room to change 2 of the lines without it getting too big.
LHeader = Worksheets("Header").Range("B2").Value
LHeader = LHeader & Chr(10) & Worksheets("Header").Range("B3").Value
LHeader = LHeader & Chr(10) & Worksheets("Header").Range("B4").Value
LHeader = "&""Calibri,Regular""&10" & LHeader & Chr(10) & Worksheets("Header").Range("B5").Value
CHeader = Worksheets("Header").Range("C2").Value
CHeader = CHeader & Chr(10) & Worksheets("Header").Range("C3").Value
CHeader = CHeader & Chr(10) & Worksheets("Header").Range("C4").Value
CHeader = "&""Calibri,Bold""&14" & CHeader & Chr(10) & Worksheets("Header").Range("B5").Value
RHeader = Worksheets("Header").Range("D2").Value
RHeader = RHeader & Chr(10) & Worksheets("Header").Range("D3").Value
RHeader = RHeader & Chr(10) & Worksheets("Header").Range("D4").Value
RHeader = "&""Calibri,Regular""&10" & RHeader & Chr(10) & Worksheets("Header").Range("D5").Value