Can you change the font format of a value you add into the footer of a document ?
I could already achieve the value itself but can't seems to find the way to change the format of it.
This is the code I have:
Sub SetValueInFooter()
Dim WorkRng As Range
On Error Resume Next
'make variable with the number
Dim TextINeed As String
TextINeed = ActiveWorkbook.Sheets("Sheet1").Range("A1").Value
'add the number into the footer left
Application.ActiveSheet.PageSetup.LeftFooter = TextINeed
'define style of the number (this 'with' section has no effect, text stays black font size 10)
With ActiveSheet.PageSetup.LeftFooter
.Font.Size = 8
.Font.Color = RGB(192, 80, 77)
End With
End Sub
Thanks for your time & help
The page setting is different from that of the normal cell. It is helpful to record macros to identify patterns.
Sub SetValueInFooter()
Dim WorkRng As Range
Dim Ws As Worksheet
Dim TextINeed As String
Set Ws = ActiveSheet
'On Error Resume Next
'make variable with the number
TextINeed = ActiveWorkbook.Sheets("Sheet1").Range("A1").Value
'add the number into the footer left
'Application.ActiveSheet.PageSetup.LeftFooter = TextINeed
'define style of the number (this 'with' section has no effect, text stays black font size 10)
With Ws.PageSetup
.LeftFooter = "&8&kc0504d" & TextINeed '<~~ 8:=font.size / c0504d:=font.color (html color) / TextINeed:= text
End With
End Sub
Related
I have a Word file with approximately 10 pages and 20 tables. Some of these tables have checkboxes. I want to copy these tables into an Excel file.
The following code copies all tables from my Word file into my Excel file:
Sub Import()
Option Explicit
Dim wb As Workbook
Dim sh As Worksheet
Dim sheet As Worksheet
Dim lzeile As Integer
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set sheet = wb.Worksheets("Tabelle1")
Dim Btxt As Object
Set Btxt = CreateObject("Word.Application")
Btxt.Visible = True
Btxt.documents.Open "C:\Users\*.doc" '*=path
lzeile = 0
For i = 1 To 20
Btxt.ActiveDocument.Tables(i).Range.Copy
Application.Goto sheet.Cells(1 + lzeile, 1)
sheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
lzeile = sheet.Cells(Rows.Count, 1).End(xlUp).Row
lzeile = lzeile + 1
sheet.Cells(lzeile, 1) = "Tabelle" & i
Next i
Btxt.Quit
Set Btxt = Nothing
Set wb = Nothing
Set sh = Nothing
End Sub
It does not copy checkboxes or the value (0 = not checked / 1 = checked) of the checkbox.
I can write the value of a checkbox into a cell in my excel sheet with this line:
sheet.Cells(j, 10) = Btxt.ActiveDocument.Tables(i).FormFields.Item("Kontrollkästchen" & j).Result
With a loop j over all "Kontrollkästchen" (german translation of contentcontrol or formfield item) so basically the name of all formfield items in this Word file.
How can I get the position of these formfield items or identify which formfield item / ContentControl is in which table?
I tried to go through all rows and columns in each table because none of them are larger than 10x10. But I can´t find a way to check if a checkbox is maybe in table 3 on column 5 row 5 and then read the name of this checkbox to a safe the value (0 / 1) in the Excel cell on the same position in my copied table.
The solution depends on whether they're formfields or content controls.
Assuming they're formfields:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
j = Abs(.CheckBox.Value)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
Assuming they're content controls:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .ContentControls.Count To 1 Step -1
With .ContentControls(i)
If .Type = wdContentControlCheckBox Then
j = Abs(.Checked)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
For the sake of simplicity and clarity, the sample code below leaves out the parts having to do with Excel, as well as creating the instance of the Word Application. It shows only how to access the Word document's checkboxes and convert those to static values.
At the end, also, the document is closed without saving changes, which means forms protection and the checkboxes should be left intact - the macro will not have affected them.
Note: You should have Option Explicit at the top of the code page, not inside a "Sub".
How it works
The document to be processed is opened and at that moment set to an object (doc). Use this instead of ActiveDocument as it will be much clearer and, in case the user would try to do something, won't affect macro execution.
If the document has forms protection, this must be turned off in order to delete the checkboxes and insert static values.
Then all the form fields are looped. If they are checkboxes, the value is determined, the checkbox removed and the value assigned to the range the checkbox occupied.
After this has completed comes the code to transfer data to Excel. Then the document is closed without saving changes.
Sub ConvertCheckBoxesToValues()
Dim ff As Object ' Word.FormField
Dim doc As Object ' Word.Document
Dim cbValue As String
Dim rngFF As Object ' Word.Range
Set doc = Btxt.Documents.Open("C:\Users\*.doc") '*=path
If doc.ProtectionType <> -1 Then 'wdNoProtection
doc.Unprotect
End If
For Each ff In doc.FormFields
If ff.Type = 71 Then 'wdFieldFormCheckBox
If ff.CheckBox.value = True Then
cbValue = "1"
Else
cbValue = "0"
End If
Set rngFF = ff.Range
ff.Delete
rngFF = cbValue
End If
Next
'Transfer the information to Excel, then
doc.Close 0 'wdDoNotSaveChanges
End Sub
I have the following macro which is supposed to create a box linking to a certain worksheet in the workbook, on each sheet of the workbook:
Option Explicit
Sub gndhnkl()
Dim ws As Worksheet
Dim sh As Shape
For Each ws In ThisWorkbook.Worksheets
If InStr(1, ws.Name, "Summering", vbBinaryCompare) <= 0 Then
For Each sh In ws.Shapes
sh.Delete
Next sh
Call Macro1(ws)
End If
Next ws
End Sub
Sub Macro1(ws As Worksheet)
Dim venstre As Double, topp As Double, breidde As Double, høgde As Double
Dim sh As Shape
venstre = ws.Range("B16").Left
topp = ws.Range("B16").Top
breidde = 110
høgde = 68
Set sh = ws.Shapes.AddShape(msoShapeRoundedRectangle, venstre, topp, breidde, høgde)
With sh.TextFrame2.TextRange
.Characters.Text = "Til summering, person"
.Font.Size = 13
.ParagraphFormat.Alignment = msoAlignCenter
.Parent.VerticalAnchor = msoAnchorMiddle
End With
ws.Hyperlinks.Add Anchor:=sh, Address:="", SubAddress:=Replace(Summering_person.Range("A1").Address(external:=True), "[" & ThisWorkbook.Name & "]", "", 1, -1, vbBinaryCompare)
End Sub
For the most part it works just like I expect it too, but for some reason the font size in the added shape is not set to 13 as I expect, but remains 11.
I.e. it seems that the line .Font.Size = 13 (sh.TextFrame2.TextRange.Font.Size = 13) is not executed.
Where is my mistake here, and what do I need to do in order for the macro to set the font size for the shape?
You have to change the order, first set the font size (and any other font properties) before you write the text. Once the text is set, it's getting trickier to change the font - every character of the TextFrame may have it's own characteristics.
.Font.Size = 13
.Characters.Text = "Til summering, person"
Update The comment of SJR is right, when using the TextFrame rather than TextFrame2, you can set the font properties of the whole text as once after the text was written.
What I want to do
I have an Access database ( C:\Users\289894\Desktop\Database1.accdb )
One of the fields of [Table1] is [Memo].
That field is of the Memo data type, with the text format set to rich text.
It makes it possible to save some records as Bold and some records saved as Italics, for example.
I want to open a connexion to this Access database from an excel file in order to read/write into this rich text field.
The code I used is the following:
Dim datab As Database
Dim rs As Recordset
Dim path As String
path = "C:\Users\289894\Desktop\Database1.accdb"
Set datab = OpenDatabase(path)
Set rs = datab.OpenRecordset("SELECT * FROM [Table1]")
Debug.Print rs!Memo
Range("A1") = rs!Memo
My question
This code works well to open a connexion and read ordinary text fields, but rich text acts in a surprising way (for me). The original text in access was "aaa". That's "aaa" in bold font.
After running the code, both the debug.print and Range("A1") have <div><strong>aaa</strong></div> written into them.
How can I change my code to send the format to excel as well? I'd like to have "aaa" written in bold in cell A1, just like it is in Access.
EDIT: Workaround
This solves the immediate problem asked by the question without really answering the question itself. It uses internet explorer to paste the text back as Rich Text, without the tags.
Sub Sample()
Dim Ie As Object
Dim rng As Range
Set rng = Feuil1.Range("A1")
Set Ie = CreateObject("InternetExplorer.Application")
With Ie
.Visible = False
.Navigate "about:blank"
.Document.body.InnerHTML = rng.Value
.ExecWB 17, 0
'Select all contents in browser
.ExecWB 12, 2
'Copy them
ActiveSheet.Paste Destination:=rng
.Quit
End With
End Sub
Give this a shot. Loop range is generic. Also, function assumes very limited HTML as shown in your example.
Sub Test()
Dim cel As Range
For Each cel In Range("A1:A100")
cel.Font.Bold = InStr(1, cel.Value, "<strong>")
cel.Font.Italic = InStr(1, cel.Value, "<i>")
cel.Value = RemoveHTML(cel.Value)
Next
End Sub
Function RemoveHTML(sHTML As String) As String
Dim sTemp As String
sTemp = sHTML
Dim bLeft As Byte, bRight As Byte
bRight = InStr(1, sTemp, "</")
bLeft = InStrRev(sTemp, ">", bRight)
RemoveHTML = Mid(sTemp, bLeft + 1, bRight - bLeft - 1)
End Function
I have an Access 2010 application where I run a SQL query and output the results to Excel. I'm using the Excel subtotal command to create subtotals. That works fine, but on the total rows only the text ("XXX Count") is bold and the values are not bold. Our client would like the entire row bold. I've tried a couple ways without success. How do I do the entire row in the subtotals?
So here is what I currently have:
This is correct except I need all of row 5, 8, 16, and 17 bold like this:
Here is my code to create the Excel file from Access (this all works except for the bold issues):
Public Sub ExportToExcel(query)
Dim appXL As Object
Dim wbk As Object
Dim wksNew As Object
Set appXL = CreateObject("Excel.Application")
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets("Sheet1")
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets(1)
Set cn = CurrentProject.AccessConnection
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Source = query
.Open
End With
With rs
'Put recordset into new wks
wksNew.Cells(2, 1).CopyFromRecordset rs
'And add headers
Dim i As Long
For i = 0 To .Fields.Count - 1
wksNew.Cells(1, i + 1).Value = .Fields(i).Name
wksNew.Cells(1, i + 1).Font.Bold = True
wksNew.Cells(1, i + 1).HorizontalAlignment = xlCenter
Next i
'Now, while the recordset is available...
'The recordset has .fields.count fields
'Subtotals are wanted from field 7 to the end
If .Fields.Count > 13 Then
ReDim ary(14 To .Fields.Count - 1)
For i = LBound(ary) To UBound(ary)
ary(i) = i
Next i
wksNew.Cells(1, 1).CurrentRegion.SubTotal GroupBy:=1, _
TotalList:=ary, Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End If
.Close
End With
End Sub
I tried this code based on this website:
Dim rCell As Range
wksNew.Columns("A:A").Select
Dim rCell As Range
For Each rCell In Selection
If Right(rCell.Value, 5) = "Count" Then
Rows(rCell.Row).Interior.ColorIndex = 36
End If
Next
but it returned a "Method or data member not found" error on the item rCell.Value.
I also tried it like this:
Dim rCell As Range
wksNew.Columns("A:A").Select
For Each rCell In Selection
If Right(rCell, 5) = "Count" Then
Selection.Font.Bold = True
End If
Next
But I got the error "ActiveX component can't create object" on the For Each line.
How do I bold the entire row for the subtotals?
You're getting an error because Access doesn't know what Selection is unless you tell it that it's connected to your Excel instance.
For Each rCell In Selection
However, don't need to select anything, or check the whole column:
Dim rCell As Range
For Each rCell In wksNew.UsedRange.Columns(1).Cells
If Right(rCell, 5) = "Count" Then
rCell.Font.Bold = True
End If
Next
Have you tried a Pivot Table?? It is easier to manage format or layout and you don't have to change too much your code because you just put your RecordSet in a PivotTableCache like the second example in this.
Rather than looping, I'd suggest collapsing the outline and formatting the visible cells:
with wksNew.Cells(1, 1).CurrentRegion
.Outlinelevel = 2
.specialcells(12).Font.Bold = True
.Outlinelevel = 3
End With
Thanks for all the suggestions. No one posted a solution that worked entirely, so here's what I ended up using:
Dim c As Object
For Each c In wksNew.Range("A1:A500")
If c.Value Like "*Total" Then
c.Offset(0, 13).Font.Bold = True
c.Offset(0, 14).Font.Bold = True
c.Offset(0, 15).Font.Bold = True
End If
Next
The only thing that concerns me is that I'm assuming this only has 500 rows. I couldn't find a way to find the number of rows and have it search only those. If I included the whole column, it took a couple minutes to complete the loop which I didn't think the client would like. Any suggestions on how to find the last row?
I would
Display level 2 of the outline, all the subtotals
Select the whole area
Use GoTo Special to select only visible cells
Apply the formatting
Change the header row formatting if it should be different
Display all the levels again (level 3)
This code demonstrates:
Sub Macro4()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Font.Bold = True
'change the header row if necessary
Range(Range("A1"), Range("A1").End(xlToRight)).Font.Italic = True
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub
I've used a small subroutine to insert a picture into my sheet by
ActiveSheet.Pictures.Insert(URL).Select
This works fine with Excel 2003 (Windows), but does not work with Excel 2011 (Mac) any more.
Therefore I modified my subroutine
(like proposed http://www.launchexcel.com/google-maps-excel-demo/),
but the subroutine stops at
theShape.Fill.UserPicture URL
with the error message
"-2147024894 (80070002) Fehler der Methode UserPicture des Objekts FillFormat"
The rectangle is green!
Sub Q1()
Dim wks As Worksheet
Dim URL As String
Dim i As Long
Dim lastRow As Long
Dim theShape As Shape
Dim pasteCell As Range
' Used Worksheet
Set wks = Worksheets("Blatt1")
' Delete already existing shapes
For Each theShape In wks.Shapes
theShape.Delete
Next theShape
' Check all existing rows in Column K
lastRow = Cells(Rows.Count, "K").End(xlUp).Row
For i = 2 To lastRow
' the URLs are already computed and stored in column K
URL = wks.Range("K" & i).Value
' try to put the images in column L
Set pasteCell = wks.Range("L" & i)
pasteCell.Select
' Create a Shape for putting the Image into
' ActiveSheet.Pictures.Insert(URL).Select is deprecated and does not work any more!!!
Set theShape = wks.Shapes.AddShape(msoShapeRectangle, pasteCell.Left, pasteCell.Top, 200, 200)
' fill the shape with the image after greening
theShape.Fill.BackColor.RGB = RGB(0, 255, 0)
theShape.Fill.UserPicture URL
Next i
End Sub
Any suggestions or hints? Probably I'm blind as a bat....
Have you tried syntax along the lines of this for setting a shape to a URL:
Sub Picadder()
Dim Pic As Shape
Set Pic = ActiveSheet.Shapes.AddPicture("http://stackoverflow.com/content/stackoverflow/img/apple-touch-icon.png", msoFalse, msoTrue, 0, 0, 100, 100)
End Sub
This code, when adapted to your efforts, might look something along the lines of this:
Sub Q1()
Dim wks As Worksheet
Dim URL As String
Dim i As Long
Dim lastRow As Long
Dim theShape As Shape
Dim pasteCell As Range
' Used Worksheet
Set wks = Worksheets("Blatt1")
' Delete already existing shapes
For Each theShape In wks.Shapes
theShape.Delete
Next theShape
' Check all existing rows in Column K
lastRow = Cells(Rows.Count, "K").End(xlUp).Row
For i = 2 To lastRow
' the URLs are already computed and stored in column K
URL = wks.Range("K" & i).Value
' try to put the images in column L
Set pasteCell = wks.Range("L" & i)
pasteCell.Select
' Create a Shape for putting the Image into
' ActiveSheet.Pictures.Insert(URL).Select is deprecated and does not work any more!!!
Set theShape = wks.Shapes.AddPicture(URL, pasteCell.Left, pasteCell.Top, 200, 200)
' Set shape image backcolor.
theShape.Fill.BackColor.RGB = RGB(0, 255, 0)
Next i
End Sub
Your urls will need to be properly formatted - I had to use quotations on my URL for the initial snippet to get it function effectively, but it may be a solution.
For Mac-Excel 2011, there is a workaround discussed by Michael McLaughlin on his blog. Evidently, it is not easy to tie images to cells in Mac-Excel 2011, if at all. Moreover, research reveals that the question of inserting images into an excel workbook has been asked many times. It also appears that it has not been readily solved through picture methods thus far in the research. Thus, a work-around may be the best solution.
The code snippet, which was very closely adapted and ported from Michael's blog, is as follows:
Function InsertImageCommentAsWorkAround(title As String, cellAddress As Range)
' Define variables used in the comment.
Dim ImageCommentContainer As comment
' Clear any existing comments before adding new ones.
Application.ActiveCell.ClearComments
' Define the comment as a local variable and assign the file name from the _
' _ cellAddress as an input parameter to the comment of a cell at its cellAddress.
' Add a comment.
Set ImageCommentContainer = Application.ActiveCell.AddComment
' With the comment, set parameters.
With ImageCommentContainer
.Text Text:=""
'With the shape overlaying the comment, set parameters.
With .Shape
.Fill.UserPicture (cellAddress.Value)
.ScaleHeight 3#, msoFalse, msoScaleFormTopLeft
.ScaleWidth 2.4, msoFalse, msoScaleFromTopLeft
End With
End With
InsertImageCommentAsWorkAround = title
End Function
I would advise adapting the comment sets into your loop, and use that to set your images into place, using the shape formatting in your loop to set the formatting of the comment shapes generated by the adapted code.