Formatting specific part of text string in VBA - vba

I am in process of creating a macro that will save the current workbook, create a new outlook message and attach the file to the message. My macro does that but I can not format the text in the body of the email to my liking.
Dim OutApp As Object
Dim OutMail As Object
Dim sBody, Customer As String
ActiveWorkbook.Save
sBody = "All," & Chr(10) & Chr(10) & "Please Approve attached Request below for " & rType & "." _
& Chr(10) & Chr(10) & "Customer: " & customer & Chr(10)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = recip
.CC = CCed
.BCC = ""
.subject = subject
.Body = sBody
.Attachments.Add ActiveWorkbook.FullName
.display
End With
On Error GoTo 0
End Sub
I want the following message to be displayed (with the format) in the email.
All,
Please Approve attached Request below for "rtype".
Customer: Stackoverflow
So, the word "customer" needs to be bold. I have tired multiple solutions but they do not work as this is creating an outlook mail object.
Any Help will be appreciated.
**
Solution: To make the HTML tags work change the body type to html by
".HTMLBody". and you will be able to use HTML Tags. Kudos to Dick
Kusleika
**

HTML tags do work. I don't know why you say they don't.
sBody = "All,<br /><br />Please Approve attached request for " & rType & ".<br /><br /><strong>Customer:</strong> " & customer & "<br />"
then instead of the .Body property, use .HTMLBody
.HTMLBody = sBody

you have a few options
1)use HTML like a few people have commented
2)put that text on a hidden sheet and format it as required then ref it to the body as a range e.g. .Body = sheets("hidden_Body").range("A1:B10")
3)of you can try using something like below (please note below is used for adding one wingding character into a string and would need to be modified to fit your purpose)
Sub Build_Wingdings(Sh As Worksheet, rng As Range)
Dim cur_L As Integer
cur_L = 1
Sheets("Word_Specifications").Range("BZ9").Copy
Sh.Range(rng.Address).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With Sheets("Word_Specifications")
.Select
For Each cell In .Range(.Range("Word_Standard_Start").Address, .Range("Word_Standard_Start").End(xlDown).Address)
If cell.value = "" Then
Else
L = Len(cell.value) + 1
With Sh.Range(rng.Address)
With .Characters(start:=cur_L, Length:=L).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 9
.Bold = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
cur_L = cur_L + L
If .value <> "" Then
add_Wingdings cur_L, 1, Sh, rng
cur_L = cur_L + 2
End If
End With
End If
Next
End With
End Sub
Sub add_Wingdings(start As Integer, Length As Integer, Sh As Worksheet, rng As Range)
With Sh.Range(rng.Address).Characters(start:=start, Length:=Length).Font
.Name = "Wingdings 3"
.FontStyle = "Regular"
.Size = 9
.Bold = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End Sub

Related

Find Text strings containing "_"

I am looking the for the correct syntax to use a text function to find strings that contain underscores. I have a very large document that has numerous tables names with underscores. They are in the format abc_def or abc_def_ghi or abc_def_ghi_jkl etc.
I have tried various combinations and cannot get anything to work as I expect it to. Below is my latest iteration.
Sub ExtractTablesToNewDocument()
'=========================
'Macro created 2008 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro creates a new document,
'finds all words consisting of 3 or more uppercase letters
'in the active document and inserts the words
'in column 1 of a 3-column table in the new document
'Each acronym is added only once
'Use column 2 for definitions
'Page number of first occurrence is added by the macro in column 3
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract Acronyms to New Document"
'Show msg - stop if user does not click Yes
Msg = "This macro finds all words consisting of 3 or more " & _
"uppercase letters and extracts the words to a table " & _
"in a new document where you can add definitions." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
.Cell(1, 3).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<*>[_]<*>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close savechanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub
Try:
.Text = "[! ]#_[! ]{1,}"
This will find strings containing however many underscores there might be, including where those strings start or end with an underscore.
Try:
Sub AcronymLister()
Application.ScreenUpdating = False
Dim StrTmp As String, StrAcronyms As String, i As Long, j As Long, k As Long, Rng As Range, Tbl As Table
StrAcronyms = "Acronym" & vbTab & "Page" & vbCr
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "[! ^13^t^11]#_[! ^13^t^11]{1,}"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found = True
If InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0 Then
StrAcronyms = StrAcronyms & .Text & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbCr
End If
If Len(.Text) = 0 Then .End = .Paragraphs(1).Range.Next.Start
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
With .Range
Set Rng = .Characters.Last
With Rng
If .Characters.First.Previous <> vbCr Then .InsertAfter vbCr
.InsertAfter Chr(12)
.Collapse wdCollapseEnd
.Style = "Normal"
.Text = StrAcronyms
Set Tbl = .ConvertToTable(Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=2)
With Tbl
.Columns.AutoFit
.Rows(1).HeadingFormat = True
.Rows(1).Range.Style = "Strong"
.Rows.Alignment = wdAlignRowCenter
End With
.Collapse wdCollapseStart
End With
End With
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub
Note: The above code puts the acronym table at the end of the current document. I've modified the Find expression to exclude tabs, paragraph breaks & line breaks.
Sub AcronymLister()
Application.ScreenUpdating = False
Dim StrTmp As String, StrAcronyms As String, i As Long, j As Long, k As Long, Rng As Range, Tbl As Table
StrAcronyms = "Acronym" & vbTab & "Page" & vbCr
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "[! ^13^t^11]#_[! ^13^t^11]{1,}"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found = True
If InStr(.Text, "_") = 0 Then
If InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0 Then
StrAcronyms = StrAcronyms & .Text & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbCr
Else
.End = .Paragraphs(1).Range.Next.Start
End If
End If
If InStr(.Text, "_") > 0 Then
If InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0 Then
StrAcronyms = StrAcronyms & .Text & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbCr
Else
.End = .Paragraphs(1).Range.Next.Start
End If
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
With .Range
Set Rng = .Characters.Last
With Rng
If .Characters.First.Previous <> vbCr Then .InsertAfter vbCr
.InsertAfter Chr(12)
.Collapse wdCollapseEnd
.Style = "Normal"
.Text = StrAcronyms
Set Tbl = .ConvertToTable(Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=2)
With Tbl
.Columns.AutoFit
.Rows(1).HeadingFormat = True
.Rows(1).Range.Style = "Strong"
.Rows.Alignment = wdAlignRowCenter
End With
.Collapse wdCollapseStart
End With
End With
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub
#macropod i added a loop to handle zero length strings and the code appears to be working. I know this is not the most efficient method, do you have any suggestions for improvement? Thank you again for walking me through this i really appreciate all your help and knowledge.

List of sheets should update when sheets are added, deleted, copied or changes name

I have a macro ("List_of_sheets") that creates a list of all the sheets in the workbook, and places the list in the "Sheetlist"-sheet underneath the "Header"-word.
The macro deletes the previous list and creates a new list, whenever I run the macro. I do this manually whenever I delete, add, copy or change the name of sheet. However, I want this to run automatically.
Thanks in advance!
Sub List_of_sheets()
Dim objSheet As Worksheet
Dim intRow As Integer
Dim strCol As Integer
Dim GCell As Range
SearchText = "Header"
Set GCell = Worksheets("Listsheet").Cells.Find(SearchText).Offset(2, -1)
GCell.End(xlDown).ClearContents
intRow = GCell.Row
strCol = GCell.Column
For Each objSheet In ActiveWorkbook.Sheets
ActiveWorkbook.Worksheets("Listsheet").Hyperlinks.Add Anchor:=ActiveWorkbook.Worksheets("Listsheet").Cells(intRow, strCol), Address:="", SubAddress:= _
"'" & objSheet.Name & "'!A1", TextToDisplay:=objSheet.Name
With ActiveWorkbook.Worksheets("Listsheet").Cells(intRow, strCol).Font
.Name = "Calibri"
.FontStyle = "Normal"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
intRow = intRow + 1
Next objSheet
End Sub
you have to go with Workbooks events, although they don't cover the case of a sheet name change
but as a workaround you could use Workbook_SheetActivate since when you change the name of a sheet and then you want to see if the list has been updated you have to activate the list sheet
so place in ThisWorkbook code pane the following:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Application.EnableEvents = False
List_of_sheets
Application.EnableEvents = True
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.EnableEvents = False
List_of_sheets
Application.EnableEvents = True
End Sub
and you could consider the following refactoring of your code
Option Explicit
Sub List_of_sheets()
Dim objSheet As Worksheet
Dim intRow As Integer
Dim strCol As Integer
Dim GCell As Range
Dim SearchText As String
SearchText = "Header"
Set GCell = Worksheets("Listsheet").UsedRange.Find(what:=SearchText, lookat:=xlWhole, LookIn:=xlValues).Offset(2, -1)
GCell.End(xlDown).ClearContents
intRow = GCell.Row
strCol = GCell.Column
Dim listSheet As Worksheet
With ActiveWorkbook
Set listSheet = .Worksheets("Listsheet")
For Each objSheet In .Sheets
listSheet.Hyperlinks.Add Anchor:=listSheet.Cells(intRow, strCol), Address:="", SubAddress:= _
"'" & objSheet.Name & "'!A1", TextToDisplay:=objSheet.Name
intRow = intRow + 1
Next objSheet
End With
With listSheet.Cells(GCell.Row, strCol).Resize(Sheets.Count).Font
.Name = "Calibri"
.FontStyle = "Normal"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
End Sub

Issues with My Web Query Macro

I wrote a Web Query macro to import financial statements from Yahoo Finance based on the value in cell A1. It was working seamlessly for the past few weeks, but suddenly, it no longer returns any data (but does not generate an error). If anyone has any insights, I would appreciate your guidance. I have posted the code below--thank you!
Sub ThreeFinancialStatements()
On Error GoTo Explanation
Rows("2:1000").Select
Selection.ClearContents
Columns("B:AAT").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Dim inTicker As String
inTicker = Range("A1")
ActiveSheet.Name = UCase(inTicker)
GetFinStats inTicker
Exit Sub
Explanation:
MsgBox "Please make sure you type a valid stock ticker symbol into cell A1 and are not trying to create a duplicate sheet." & _
vbLf & " " & _
vbLf & "Also, for companies with different classes of shares (e.g. Berkshire Hathaway), use a hyphen to designate the ticker symbol instead of a period (e.g. BRK-A)." & _
vbLf & " " & _
vbLf & "Please also note that not every company has three years of financial statements, so data may appear incomplete or missing for some companies.", _
, "Error"
Exit Sub
End Sub
Sub GetFinStats(inTicker As String)
'
' GetBalSheet Macro
'
'
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/bs?s=" & inTicker & "+Balance+Sheet&annual", Destination:= _
Range("$D$1"))
.Name = "bs?s=PEP+Balance+Sheet&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/is?s=" & inTicker & "+Income+Statement&annual", Destination _
:=Range("$J$1"))
.Name = "is?s=PEP+Income+Statement&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/cf?s=" & inTicker & "+Cash+Flow&annual", Destination:= _
Range("$P$1"))
.Name = "cf?s=PEP+Cash+Flow&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("A3").Select
ActiveCell.FormulaR1C1 = "Current Ratio"
Range("A4").Select
ActiveCell.FormulaR1C1 = "Quick Ratio"
Range("A5").Select
ActiveCell.FormulaR1C1 = "Cash Ratio"
Range("A6").Select
Range("A7").Select
ActiveCell.FormulaR1C1 = "Revenue Growth Rate"
Range("A9").Select
Columns("A:A").ColumnWidth = 21.86
ActiveCell.FormulaR1C1 = "ROA"
Range("A10").Select
ActiveCell.FormulaR1C1 = "ROE"
Range("A11").Select
ActiveCell.FormulaR1C1 = "ROIC"
Range("B3").Select
ActiveCell.Formula = "=F11/F28"
Range("B4").Select
ActiveCell.Formula = "=(F11-F8)/F28"
Range("B5").Select
ActiveCell.Formula = "=F5/F28"
Range("B7").Select
ActiveCell.Formula = "=(L2/N2)^(1/2)-1"
Range("B9").Select
ActiveCell.Formula = "=L35/SUM(F12:F18)"
Range("B10").Select
ActiveCell.Formula = "=L35/F47"
Range("B11").Select
ActiveCell.Formula = "=L35/(F47+SUM(F29:F33))"
Range("B3").Select
Selection.NumberFormat = "0.00"
Range("B4").Select
Selection.NumberFormat = "0.00"
Range("B5").Select
Selection.NumberFormat = "0.00"
Range("B7").Select
Selection.NumberFormat = "0.00%"
Range("B9").Select
Selection.NumberFormat = "0.00%"
Range("B10").Select
Selection.NumberFormat = "0.00%"
Range("B11").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
End Sub
Your code is obviously working against a specific worksheet:
Rows("2:1000").Select
But what sheet is that? Only you can know that.
As written, it's whatever the active worksheet is, regardless of how much sense that makes.
Unqualified, these functions all implicitly refer to the ActiveSheet:
Range
Cells
Columns
Rows
Names
So you need to qualify them. And you do that by specifying a specific Worksheet object they should be working with - suppose that's DataSheet (I've no idea):
DataSheet.Rows("2:1000").Select
That would .Select the specified rows on the worksheet pointed to by the DataSheet object.
By why do you need to .Select it? This:
Rows("2:1000").Select
Selection.ClearContents
Could just as well be:
DataSheet.Rows("2:1000").ClearContents
Or better - assuming your data is formatted as a table (seems it looks like one anyway - so why not use the ListObjects API?):
DataSheet.ListObjects("DataTable").DataBodyRange.Delete
Sounds like that instruction has just replaced all the .Select and .ClearContents going on here. Note that .Select mimicks user action - the user clicking on a cell (or anything really) and selecting it. You have programmatic access to the entire object model - you never need to .Select anything!
Dim inTicker As String
inTicker = Range("A1")
Here you're implicitly reading from the active sheet, but you're also implicitly converting a Variant (the cell's value) into a String, which may or may not succeed. If A1 contains an error value (e.g. #REF!), the instruction fails.
With DataSheet.Range("A1")
If Not IsError(.Value) Then
inTicker = CStr(.Value)
Else
'decide what to do then
End If
End With
Your error-handling subroutine should at least Debug.Print Err.Number, Err.Description so that you have a bit of a clue about why things blew up. Right now it's assuming a reason for failure, and as you saw, Excel is full of traps.
Also you're using vbLf, but that's only half of a proper Windows newline character. Use vbNewLine if you're not sure what that is.
An Exit Sub instruction just before an End Sub token is completely useless.
Sub GetFinStats(inTicker As String)
The procedure is implicitly Public, and inTicker is implicitly passed ByRef. Kudos for giving it an explicit type!
This would be better:
Private Sub GetFinStats(ByVal inTicker As String)
With ActiveSheet.QueryTables
At least that's explicit about using the active sheet. But should it use the active sheet, or a specific sheet? And what happens to the query tables that were already there?
I strongly recommend you type this in the immediate pane:
?ThisWorkbook.Connections.Count
If the number is greater than the number of .QueryTables.Add calls you have in your procedure (likely), you have quite a problem there: I suspect you have over a hundred connections in the workbook, and clicking the "Refresh All" button takes forever to finish, and it's fairly possible that finance.yahoo.com is receiving dozens of requests from a single IP in a very limited amount of time, and refuses to serve them.
Delete all unused workbook connections. And then fix the implicit ActiveSheet references there too, and get rid of all these useless .Select calls:
With TheSpecificSheet
With .QueryTables.Add( ... )
End With
With .QueryTables.Add( ... )
End With
With .QueryTables.Add( ... )
End With
'assgin .Value, not .FormulaR1C1; you're not entering a R1C1 formula anyway
.Range("A3").Value = "Current Ratio"
.Range("A4").Value = "Quick Ratio"
.Range("A5").Value = "Cash Ratio"
End With
Consecutive .Select calls mean all but the last one serve a purpose, if any:
Range("A6").Select
Range("A7").Select
Again, don't assign ActiveCell when you can assign .Range("A7").Value directly.
And you can set number formats for a range of cells:
.Range("B3:B11").NumberFormat = "0.00%"
You can still retrieve the necessary data by parsing JSON response either from
https://finance.yahoo.com/quote/AAPL/financials(extracting data from HTML content, AAPL here just for example)
or via API
https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?lang=en-US&region=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings
You may use the below VBA code to parse response and output result. Import JSON.bas module into the VBA project for JSON processing. Here are Sub Test_query1_finance_yahoo_com() to get data via API and Test_finance_yahoo_com_quote to extract data from HTML content:
Option Explicit
Sub Test_query1_finance_yahoo_com()
Dim sSymbol As String
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
sSymbol = "AAPL"
' Get JSON via API
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://query1.finance.yahoo.com/v10/finance/quoteSummary/" & sSymbol & "?lang=en-US&region=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings", False
.Send
sJSONString = .ResponseText
End With
' Parse JSON response
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
Exit Sub
End If
' Pick core data
Set vJSON = vJSON("quoteSummary")("result")(0)
' Output
QuoteDataOutput vJSON
MsgBox "Completed"
End Sub
Sub Test_finance_yahoo_com_quote()
Dim sSymbol As String
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
sSymbol = "AAPL"
' Get webpage HTML response
With CreateObject("Msxml2.XMLHTTP")
.Open "GET", "https://finance.yahoo.com/quote/" & sSymbol & "/financials", False
.Send
sJSONString = .ResponseText
End With
' Extract JSON from HTML content
sJSONString = "{" & Split(sJSONString, "root.App.main = {")(1)
sJSONString = Split(sJSONString, "}(this));")(0)
sJSONString = Left(sJSONString, InStrRev(sJSONString, "}"))
' Parse JSON response
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
Exit Sub
End If
' Pick core data
Set vJSON = vJSON("context")("dispatcher")("stores")("QuoteSummaryStore")
' Output
QuoteDataOutput vJSON
MsgBox "Completed"
End Sub
Sub QuoteDataOutput(vJSON)
Const Transposed = True ' Output option
Dim oItems As Object
Dim vItem
Dim aRows()
Dim aHeader()
' Fetch main structures available from JSON object to dictionary
Set oItems = CreateObject("Scripting.Dictionary")
With oItems
.Add "IncomeStatementY", vJSON("incomeStatementHistory")("incomeStatementHistory")
.Add "IncomeStatementQ", vJSON("incomeStatementHistoryQuarterly")("incomeStatementHistory")
.Add "CashflowY", vJSON("cashflowStatementHistory")("cashflowStatements")
.Add "CashflowQ", vJSON("cashflowStatementHistoryQuarterly")("cashflowStatements")
.Add "BalanceSheetY", vJSON("balanceSheetHistory")("balanceSheetStatements")
.Add "BalanceSheetQ", vJSON("balanceSheetHistoryQuarterly")("balanceSheetStatements")
.Add "EarningsChartQ", vJSON("earnings")("earningsChart")("quarterly")
.Add "FinancialsChartY", vJSON("earnings")("financialsChart")("yearly")
.Add "FinancialsChartQ", vJSON("earnings")("financialsChart")("quarterly")
End With
' Output each data set to separate worksheet
For Each vItem In oItems
' Convert each data set to array
JSON.ToArray oItems(vItem), aRows, aHeader
' Output array to worksheet
With GetSheet((vItem))
.Cells.Delete
If Transposed Then
Output2DArray .Cells(1, 1), WorksheetFunction.Transpose(aHeader)
Output2DArray .Cells(1, 2), WorksheetFunction.Transpose(aRows)
Else
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aRows
End If
.Columns.AutoFit
End With
Next
End Sub
Function GetSheet(sName As String, Optional bCreate = True) As Worksheet
On Error Resume Next
Set GetSheet = ThisWorkbook.Sheets(sName)
If Err Then
If bCreate Then
Set GetSheet = ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
GetSheet.Name = sName
End If
Err.Clear
End If
End Function
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Finally Sub QuoteDataOutput(vJSON) input is a JSON object, to make it clear how the necessary data is being extracted from it, you may save the JSON string to file, copy the contents and paste it to any JSON viewer for further study. I use online tool http://jsonviewer.stack.hu, target element structure is shown below:
The output for me is as follows (first worksheet shown):
There are 9 main sections, the relevant part of the data is extracted and output to 9 worksheets:
IncomeStatementY
IncomeStatementQ
CashflowY
CashflowQ
BalanceSheetY
BalanceSheetQ
EarningsChartQ
FinancialsChartY
FinancialsChartQ
Having that example you can extract the data you need from that JSON response.
It turns out that Yahoo ended the application from which the web query drew its data. Thank you for all your tips.

MS WORD 2010 Using VBA to type text into table cell then reformat and type more text w/o deleting previous text

I am using this code which specifically places the text in the precise cell I want using this code:
Dim myText1 As String
Dim myText2 As String
myText1 = "Header"
myText2 = "Body"
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Font.Name = "Times New Roman"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
.Text = myText1 & vbCr & vbCr & myText2
End With
The problem I am having is "myText2" is not supposed to be underlined or bold.
I have tried this:
Dim myText1 As String
Dim myText2 As String
myText1 = "Header"
myText2 = "Body"
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Font.Name = "Times New Roman"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
.Text = myText1 & vbCr & vbCr
.Font.Bold = False
.Font.Underline = False
.Text = myText2
End With
But what happens is the first myText1 gets deleted and all I am left with is myText2.
and this
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Font.Name = "Times New Roman"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
.InsertAfter myText1 & vbCr & vbCr
.Font.Bold = False
.Font.Underline = False
.InsertAfter myText2
While this appends the text, the formatting for the entire post is no underline or bold, when the end result is supposed to look like
Header
Body
How can I reformat myText2, have it post, without losing the formatted myText1 above?
In your code you have set the With statement to work with the entire range of the cell. This results in the formatting being applied to the entire cell.
You don't have to use the Selection object to apply formatting, you just need to make sure that you are working with the correct range. Using the Selection object makes the code run more slowly as it moves the cursor around.
I have rewritten your code below.
Sub AddTextToCell()
Dim myText1 As String
Dim myText2 As String
myText1 = "Header"
myText2 = "Body"
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Text = myText1 & vbCr & vbCr & myText2
With .Font
.Name = "Times New Roman"
.Size = 12
.Bold = False
.Underline = False
End With
With .Paragraphs.First.Range.Font
.Bold = True
.Underline = True
End With
End With
End Sub
Normally it is better to enter text the way you do, without using Select, but when applying different formats to different parts of a cell I think you have to use it. I had to change the order of the formatting and step around a bit in the document to make it work:
Dim myText1 As String
Dim myText2 As String
myText1 = "Header"
myText2 = "Body"
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Font.Name = "Times New Roman"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
.Text = myText1 & vbCr & vbCr
End With
'Select the whole cell
ActiveDocument.Tables(1).Cell(2, 2).Select
'Move to the right
Selection.Collapse Direction:=wdCollapseEnd
'Move back to the left
Selection.MoveLeft wdCharacter, 1
'Add the text (using the myText1 format)
Selection.Range.Text = myText2
'Select the on word the right (myText2)
Selection.MoveRight wdWord, 1, True
'Format myText2
Selection.Range.Font.Underline = False
Selection.Range.Font.Bold = False

Leading zero in CSV on reopen [duplicate]

This question already has answers here:
Excel CSV - Number cell format
(16 answers)
Closed 9 years ago.
I have txt file which looks like below
I am importing the txt file in excel using the method shown here. Column Account is converted to text.
Once the data is imported, file looks like below.
I have a requirement to save the file as csv which is then imported by different system.
The problem is on reopen the csv file looks like below. The leading zero in account column disappears. I cannot add ' in front of Account column cells bcoz the system does not accepts. What can be done to preserve the leading zero on csv open/ reopen ?
I m doing this all using vba
Sub createcsv()
Dim fileName As String
Dim lastrow As Long
Dim wkb As Workbook
lastrow = Range("C" & Rows.Count).End(xlUp).Row
'If lastrow < 6 Then lastrow = 6
For i = lastrow To 3 Step -1
If Cells(i, 4).Text = vbNullString Then
Cells(i, 1).EntireRow.Delete
ElseIf Trim(Cells(i, 4).Value) = "-" Then
Cells(i, 1).EntireRow.Delete
ElseIf Cells(i, 4).Value = 0 Then
Cells(i, 1).EntireRow.Delete
ElseIf CDbl(Cells(i, 4).Text) = 0 Then
Cells(i, 1).EntireRow.Delete
End If
Next
lastrow = Range("C" & Rows.Count).End(xlUp).Row
'If lastrow < 6 Then lastrow = 6
retval = InputBox("Please enter journal Id", Default:="G")
Range("A3:A" & lastrow) = retval
retval = InputBox("Please enter Date", Default:=Date)
Range("B3:B" & lastrow) = retval
retval = InputBox("Please enter description", Default:="Master entry")
Range("E3:E" & lastrow) = retval
Dim strVal As String
strVal = InputBox("Please enter File Name", Default:="Data")
filePath = CreateFolder(strVal)
fileName = GetFileName(filePath)
ThisWorkbook.Sheets("Sheet1").Copy
Set wkb = ActiveWorkbook
Set sht = wkb.Sheets("sheet1")
Application.DisplayAlerts = False
wkb.SaveAs fileName:=filePath, FileFormat:=xlCSV
sht.Cells.Clear
importTxt wkb, filePath, fileName
sht.Columns("A:A").NumberFormat = "General"
sht.Columns("B:B").NumberFormat = "M/d/yyyy"
sht.Columns("D:D").NumberFormat = "0.00"
sht.Columns("E:E").NumberFormat = "General"
wkb.SaveAs fileName:=Replace(filePath, ".txt", ".csv"), FileFormat:=xlCSV
wkb.Close
Set wkb = Nothing
Application.DisplayAlerts = True
err_rout:
Application.EnableEvents = True
End Sub
Function CreateFolder(Optional strName As String = "Data") As String
Dim fso As Object, MyFolder As String
Set fso = CreateObject("Scripting.FileSystemObject")
MyFolder = ThisWorkbook.Path & "\Reports"
If fso.FolderExists(MyFolder) = False Then
fso.CreateFolder (MyFolder)
End If
MyFolder = MyFolder & "\" & Format(Now(), "MMM_YYYY")
If fso.FolderExists(MyFolder) = False Then
fso.CreateFolder (MyFolder)
End If
CreateFolder = MyFolder & "\" & strName & Format(Now(), "DD-MM-YY hh.mm.ss") & ".txt"
Set fso = Nothing
End Function
Sub importTxt(ByRef wkb As Workbook, ByVal txtLink As String, ByVal fileName As String)
With wkb.Sheets(fileName).QueryTables.Add(Connection:= _
"TEXT;" & txtLink, _
Destination:=Range("$A$2"))
.Name = fileName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 2, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
Function GetFileName(ByVal fullName As String, Optional pathSeparator As String = "\") As String
'?sheet1.GetFileName( "C:\Users\Santosh\Desktop\ssss.xlsx","\")
Dim i As Integer
Dim tempStr As String
Dim iFNLenght As Integer
iFNLenght = Len(fullName)
For i = iFNLenght To 1 Step -1
If Mid(fullName, i, 1) = pathSeparator Then Exit For
Next
tempStr = Right(fullName, iFNLenght - i)
GetFileName = Left(tempStr, Len(tempStr) - 4)
End Function
This is an unfortunate problem in MS Excel. I could not find any way around this, except to change the format and use xls. I was supplying data to my desktop application from a csv file that could be edited by anyone. Unfortunately, the leading zero problem stayed despite various things I tried. The only reliable method I found was to have a !before the number !00101 so that it was accepted as a string. This was okay for the application(it could replace the ! with nothing), but still the human readability factor was affected.
Depending on your application and use, you might have to use a different format.