My Excel macro reads the answers to a survey from a set of Excel files. The answers of a survey contain a score (from 1 to 4) and a description. The goal is to generate a a matrix. Each cell of the matrix has a color that represents the score. I would like the user to be able to modify the layout of these cell. To make it easy to the user, I created a template matrix and a button. The user should be able to modify the layout of the cells and on a click of a button, a set of styles (Score 1, Score 2,...) should be generated. Once the matrix is created, the Workbook should be to function without the survey files.
I have tried a couple of things:
Try 1
ThisWorkbook.Styles.Add "Score 1", BasedOn:=cell1
This gives errors. I don't fully understand when they occur, but one of the causes is when the user modifies the cell layout by selecting another style.
Try 2
ThisWorkbook.Styles("Score 1").Delete
ThisWorkbook.Styles.Add "Score 1", BasedOn:=cell1
This is not a good idea: all cells loose their styling when it is executed a second time.
Try 3: Current
Copy the most frequently used properties of the cells layout and copy them to the style. If this style is deleted by the user, it is recreated. This procedures is not ideal, since most style properties won't be covered.
Is there a way to update a cell style that is more general? I would like there to be as little room as possible to make the workbook in an inconsistent and non-functional state.
I sticked with try 3. Because it required a lot of code for all properties that seemed possible to be edited, and because of copying borders is tricky, I post the result.
'xR1_Template: the cell to base the style on
'nm_Style: the name of the style
Public Function Upsert_Style(xR1_Template As Excel.Range, nm_Style As String) As Excel.Style
Dim xStyle As Excel.Style
Set xStyle = Fn.TryGet(ThisWorkbook.Styles, nm_Style)
If Fn.IsNothing(xStyle) Then
Set xStyle = ThisWorkbook.Styles.Add(nm_Style)
End If
xStyle.Font.Color = xR1_Template.Font.Color
xStyle.Font.Bold = xR1_Template.Font.Bold
xStyle.Font.Name = xR1_Template.Font.Name
xStyle.Font.Italic = xR1_Template.Font.Italic
xStyle.Font.Size = xR1_Template.Font.Size
xStyle.Font.Strikethrough = xR1_Template.Font.Strikethrough
xStyle.Font.Subscript = xR1_Template.Font.Subscript
xStyle.Font.Superscript = xR1_Template.Font.Superscript
xStyle.Font.Underline = xR1_Template.Font.Underline
xStyle.Interior.Color = xR1_Template.Interior.Color
xStyle.Interior.Pattern = xR1_Template.Interior.Pattern
xStyle.Interior.PatternColor = xR1_Template.Interior.PatternColor
'NOTE: necessary to delete all borders first. There's no way to delete them one by one.
xStyle.Borders.LineStyle = xlNone
Dim iBorder As Long
For iBorder = 1 To xR1_Template.Borders.Count
Dim xBorder As Excel.Border
'NOTE: The Borders property claims to work with xlBordersIndex argument, but this is not true.
' Normal indexing is used.
Set xBorder = xR1_Template.Borders(iBorder)
'NOTE: "none-style" borders (=no border), should be skipped.
' Once they are retrieved using the Borders property, they are always visible.
' Setting them with xlLineStyle.xlLineStyleNone does not hide them.
If xBorder.LineStyle <> XlLineStyle.xlLineStyleNone Then
Dim xBorder_Style As Excel.Border
Set xBorder_Style = xStyle.Borders(iBorder)
xBorder_Style.Color = xBorder.Color
xBorder_Style.LineStyle = xBorder.LineStyle
xBorder_Style.Weight = xBorder.Weight
End If
Next iBorder
xStyle.AddIndent = xR1_Template.AddIndent
xStyle.FormulaHidden = xR1_Template.FormulaHidden
xStyle.HorizontalAlignment = xR1_Template.HorizontalAlignment
xStyle.IndentLevel = xR1_Template.IndentLevel
xStyle.NumberFormat = xR1_Template.NumberFormat
xStyle.NumberFormatLocal = xR1_Template.NumberFormatLocal
xStyle.Orientation = xR1_Template.Orientation
xStyle.ShrinkToFit = xR1_Template.ShrinkToFit
xStyle.VerticalAlignment = xR1_Template.VerticalAlignment
xStyle.WrapText = xR1_Template.WrapText
xStyle.IndentLevel = xR1_Template.IndentLevel
Set Upsert_Style = xStyle
End Function
Related
I am trying to automate the preparation of an internal Excel-based report based on a previous template.
The macro creates and fills a new sheet, matching the font name, size, color etc. settings of the template, as well as the row heights - column widths. Despite providing the exact same values for font, height, width etc., the VBA produced sheet's font does not match the original template. I believe the issue can be fixed if we can figure out why the VBA produced text is "pixelated".
As I am not familiar with the file sharing best-practices of SO, I will be including code used to reproduce the new sheet and a comparison of some attributes of the both sheets. I will include a link to the file containing the two sheets in the comments. I believe it may be important to have a copy of the original template to answer this question.
Here is an example of how a cell's properties are changed, pretty basic.
ws.Columns(12).EntireColumn.ColumnWidth = 9.57
ws.Rows(9).EntireRow.RowHeight = 50.25
ws.Cells(9, 12).Font.Name = "Segoe UI"
ws.Cells(9, 12).Font.Size = 11
Here are some properties I compared for the two sheets as I did not know what I was looking for, all are identical for the two sheets.
Range.AddIndent = False
Range.ColumnWidth = 9.57
Range.RowHeight = 50.25
Range.Font.Name = "Segoe UI"
Range.Font.FontStyle = "Regular"
Range.Font.Size = 11
Range.Font.ThemeFont = xlThemeFontNone
Range.Font.ThemeColor = 2
Range.Font.OutlineFont = False
Range.Font.Subscript = False
Range.Font.Superscript = False
Range.Font.Italic = False
Range.HasSpill = False
Range.Phonetics = Nothing
Range.PrefixCharacter = ""
Range.SpillingToRange = Nothing
Range.UseStandardHeight = True
Range.UseStandardWidth = False
Range.WrapText = True
Worksheet.Cells.AddIndent = False
Worksheet.EnableOutlining = False
Worksheet.Outline.AutomaticStyles = False
Worksheet.PageSetup.BottomMargin = 18 'These are different, but did not effect the outcome when equalized
Worksheet.PageSetup.LeftMargin = 50.4 'These are different, but did not effect the outcome when equalized
Worksheet.PageSetup.FooterMargin = 21.6 'These are equal for both
Worksheet.PageSetup.HeaderMargin = 21.6 'These are equal for both
Worksheet.StandardHeight = 16.5 'These are different, yet read-only
Worksheet.StandardWidth = 8.38 'These are different, yet read-only
I know a little HTML/CSS and my guess is despite having the same font families(names), the .woff2 or .eot are different for the two fonts. I have no idea why though.
Painting the target cells using the original template format does the job, as does a copy/pasting strategy, but I am aiming for a clean solution without including the template in the final file and generating the sheets from scratch. I could also change the font family or cell sizes to get an acceptable output, but at this point I wish to explore the reason behind this issue out of curiosity.
UPDATE!
My goal is to modify an existing Workbook ( example - master_v2.xlsm ) and produce a new workbook (Newclient4) based on the updates made to master_v2.
I'm using a single sheet within master_v2 to collect all the data which will be determining what the new workbook will be.
Currently using multiple if statements to find the value of the cells in this "repository" sheet. Based on specific cells, I'm creating and adding values to copies of an existing sheet called "PANDAS".
My goal right now is to create a dict based on two columns. The loop through
the keys so that every time I get a hit on a cell, I will gather values from specific keys.
That's listed below:
from openpyxl import load_workbook
# Start by opening the spreadsheet and selecting the main sheet
workbook = load_workbook(filename="master_v2.xlsm",read_only=False, keep_vba=True)
DATASOURCE = workbook['repository']
DATASOURCE["A:H"]
cell100 = DATASOURCE["F6"].value
CREATION = cell100
cell101 = DATASOURCE["F135"].value
CREATION2 = cell101
cell107 = DATASOURCE["F780"].value
CREATION7 = cell107
if CREATION.isnumeric():
source = workbook['PANDAS']
target = workbook.copy_worksheet(source)
ss_sheet = target
ss_sheet.title = DATASOURCE['H4'].value[0:12]+' PANDAS'
if CREATION2.isnumeric():
source = workbook['PANDAS']
target = workbook.copy_worksheet(source)
ss_sheet = target
ss_sheet.title = DATASOURCE['H133'].value[0:12]+' PANDAS'
if CREATION3.isnumeric():
source = workbook['PANDAS']
target = workbook.copy_worksheet(source)
ss_sheet = target
ss_sheet.title = DATASOURCE['H262'].value[0:12]+' PANDAS'
else:
print ("no")
workbook.save(filename="NewClient4.xlsm")
Instead of the many if statements I was hoping to be able to loop through the column as explained above,
once I found my value, gather data and copy it over to a copy of sheet which is then filled out by other cells. Each time the loop comples, I want to do repeat on the next match of the string.. but I'm only this far and it's not quite working.
Anyone have a way to get this working?
( trying to replace the many one to one mappings and if statements )
for i in range(1,3000):
if DATASOURCE.cell(row=i,column=5).value == "Customer:":
source = workbook['Design details']
target = workbook.copy_worksheet(source)
ss_sheet = target
ss_sheet.title = DATASOURCE['H4'].value[0:12]+' Design details'
else:
print ("no")
Thank you guys in advanced
I have a userform in Excel 2016 that will generate a certain group of shapes (a welding symbol, if the context is helpful), mainly consisting of lines, arcs, and textboxes. Some of these will be the same every time the code is run, while others are options to be determined by the user via the userform. At the end those elements are grouped into a single symbol. My current code works as described thus far.
The problem comes when I try to run the form a second time (generating a second group of shapes independent of the first group). I have it set up such that as the code is executed, it creates a shape, names that shape appropriately, then groups all shapes at the end, referring to them by name. The second time the code is run, it uses the same names as in the first run. As soon as it tries to form the second group, I get an error due to names referring to two different shapes.
My question is this: Is there a way to add shapes to a group (or to a collection to be grouped later) as they are created? It seems naming shapes isn't the way to go, as the names are retained after the code ends. I tried referencing by shape index, but since I have images on the page as well, it's hard to determine exactly what a particular shape's index is. I apologize for the lack of code, as I don't have access to it right now. If needed I can write up something simple to get the point across. Any help is greatly appreciated!
You can group shapes with a command like this:
Dim ws as Worksheet
Set ws = ActiveSheet ' <-- Set to the worksheet you are working on
ws.Shapes.Range(Array("Heart 1", "Sun 2", "Star 3")).Group
(you can access the shapes via name or via index). The result of the group command is another shape that is added to the sheet. But be aware that the grouped shapes still exists in the sheet, you can access them with the GroupItems-property.
With ws.Shapes
Dim shGroup As Shape, sh As Shape
Set shGroup = .Range(Array("Heart 1", "Sun 2", "Star 3")).Group
shGroup.Name = "MyNewGroup" & .Count
For Each sh In shGroup.GroupItems
Debug.Print sh.Name, sh.Type
Next sh
End With
As you can see, the single shape elements don't change their names, so grouping would not solve your naming issue. The only way is to add a suffix to the name, e.g. a number (as Excel does it when it creates a shape).
Update: Of course the Array- parameter does not need to be static. You can declare an array that is large enough (it doesn't matter if it contains some empty elements).
Const maxShapes = 12
Dim myShapes(1 to maxShapes) as String
myShapes(1) = *Name of first shape you created*
myShapes(2) = *Name of second shape you created*
...
ws.Shapes.Range(myShapes).Group
or use the Redim command:
Dim myShapes() as String
Redim myShapes(1 to NumberOfShapesInYourNewGroup)
myShapes(1) = *Name of first shape you created*
myShapes(2) = *Name of second shape you created*
...
ws.Shapes.Range(myShapes).Group
To get a unique shape and group name, you can implement various methods. I don't like the attempt with a global variable as they might get reset - for example when you cancel execution during debugging. You could use for example the suffix that Excel generates when you create a new shape. Or put the rename-statement into a loop, put a On error Resume Next before the rename (and don't forget to put an On error Goto 0 after it) and loop until renaming was successfull. Or loop over all shapes in your sheet to find the next free name.
After some trial and error, the solution I came up with is something like the following.
'Count shapes already on sheet
Shapesbefore=ActiveSheet.Shapes.Count
'Create new shapes
'Create array containing indexes of recently created shapes
Dim shparr() As Variant
Dim shprng As ShapeRange
ReDim shparr(Shapestart + 1 To ActiveSheet.Shapes.Count)
For i = LBound(shparr) To UBound(shparr)
shparr(i) = i
Next i
'Group shapes and format weight/color
Set shprng = ActiveSheet.Shapes.Range(shparr)
With shprng
.Group
.Line.Weight = 2
.Line.ForeColor.RGB = 0
End With
This way I don't have to worry about creating and managing various group and shape names, as I don't need to go back and reference them later.
I need combo boxes to be placed in specific positions in relation to the cells on this Worksheet. I was attempting to utilize a while loop to change a variables value and utilize that variable to dynamic change a cell. However, my code doesn't seem to be working. The loop will run through once, but will give me a "object does not support this property or method" error on the successive loop.
Dim t As Integer
Dim wotype as object
t = 1
Do While t < 43
wotype = ActiveSheet.Shapes.AddFormControl(xlDropDown, Left:=Cells(4, t).Left, Top:=Cells(3, t).Top, Width:=25.29, Height:=Rows(3).RowHeight)
t = t + 3
Loop
When assigning an object to a variable, you need to use the Set keyword...
set wotype = ActiveSheet.Shapes.AddFormControl(xlDropDown, Left:=Cells(4, t).Left, Top:=Cells(3, t).Top, Width:=25.29, Height:=Rows(3).RowHeight)
Although, in this case, since you're not subsequently referring to your variable, your code can be re-written as follows...
Dim t As Integer
t = 1
Do While t < 43
ActiveSheet.Shapes.AddFormControl xlDropDown, Left:=Cells(4, t).Left, Top:=Cells(3, t).Top, Width:=25.29, Height:=Rows(3).RowHeight
t = t + 3
Loop
I want to add data to a bunch of existing charts. Assume that each chart has a different number of data series and that the location of the raw data is somewhere in the same workbook. Here's what I'm starting with:
For iChart = 1 To iCount
ActiveSheet.ChartObjects("Chart " & iChart).Activate
intSeries = 1
Do Until ActiveChart.SeriesCollection(intSeries).Name = ""
Set rXVal = ActiveChart.SeriesCollection(intSeries).XValues '<- Object Required error
Set rXVal = Range(rXVal, rXVal.End(xlDown))
Set rYVal = ActiveChart.SeriesCollection(intSeries).Values
Set rYVal = Range(rYVal, rYVal.End(xlDown))
ActiveChart.SeriesCollection(intSeries).XValues = rXVal
ActiveChart.SeriesCollection(intSeries).Values = rYVal
intSeries = intSeries + 1
Loop
Next iChart
I know that ActiveChart...XValues = rXVal works, but I'm getting an "Object Required" error on the Set rXVal = ActiveChart....XValues line. I'm assuming that since a range went in to define the data series, I can get that range back out again and then add to it.
UPDATE
To clarify things a little, I have accelerometers in 8 places and FFT software setup to record peak vibration response in 4 separate frequency bands. This yields 32 data points per sample. When exporting, the software spits out an Excel workbook with 4 sheets; one for each frequency band. Each sheet has the accelerometer names going across and sample numbers going down.
I have succeeded using this syntax:
Dim rXVal() As Variant
rXVal = ActiveChart.SeriesCollection(intSeries).XValues
UPDATE
In this case you get an array, because your given statement (ActiveChart.SeriesCollection(intSeries).XValues) is an array and not a range. This is what you see in Locals window if you dig into Series object of ActiveChart.SeriesCollection(intSeries):
(in my dummy data I have rows named r1, r2, r3, r4.)
What I want to say, XValues does not have any property which would indicate its occupied range.
If you actually need a range, I would suggest getting it from the formula property. And the way I would suggest is replacing your error causing line with this one:
Set rXVal = Range(Split(ActiveChart.SeriesCollection(intSeries).Formula, ",")(1))
Next, I see you trying to get the range for Values. Similarly, use this:
Set rYVal = Range(Split(ActiveChart.SeriesCollection(intSeries).Formula, ",")(2))
Another thing.
The following lines will cause you an error finally:
intSeries = 1
Do Until ActiveChart.SeriesCollection(intSeries).Name = ""
...some code...
intSeries = intSeries + 1
Loop
Do change them with:
For intSeries = 1 To ActiveChart.SeriesCollection.Count
...some code...
Next
Yet another thing.
Consider using With and End With, as you repeat a lot ActiveChart.SeriesCollection(intSeries). Then your code will be much more readable, as you would just skip this long line! Wouldn't that be awesome???
This works fine for me:
Dim rXVal() As Variant
Dim rXValMin, rXValMax As Double
rXVal = ActiveChart.SeriesCollection(intSeries).XValues
rXValMin = WorksheetFunction.Min(rXVal)
rXValMax = WorksheetFunction.Max(rXVal)