I have found the below code (changed to my needs) here
I try to change the titles of many charts automatically, using macro in libre calc 7.3.0.
I Know which cells contain the titles and I want them to add them to charts.
How can I make this VBA vcode to work?
Const SCells = "L8, T8, AA8"
' Set the title of the first Chart to the contents of C1
Sub SetTitle
' Get active sheet
oSheet = ThisComponent.CurrentController.ActiveSheet
aCells = Split(SCells,",")
for i = uBound(aCells) to 0 step -1
' Get the cell containing the chart title, in this case C1
oCell = oSheet.getCellRangeByName(aCells(i))
oCharts = oSheet.getCharts()
' Get the chart with index 0, which is the first chart created
' to get the second you would use 1, the third 2 and so on...
oChart = oCharts.getByIndex(i)
oChartDoc = oChart.getEmbeddedObject()
'Change title
oChartDoc.getTitle().String = oCell.getString()
next i
End Sub
What I was doing wrongly? I had spaces in Const SCells content:
"L11, T11, E11" which was wrong.
I checked the content of aCells using xraytool and I found that the content was parsed as 1) "L11", 2) " T11" and 3) " E11", with spaces.
So you can change automatically the title of your charts in a librecalc sheet using that vba code:
' NOTE: NO SPACES OR OTHER CHARACTERS
Const SCells = "L11,T11,E11"
Sub SetTitle
' Get active sheet
oSheet = ThisComponent.CurrentController.ActiveSheet
' Split SCells content by ","
' see Print aCells for corrent content
aCells = Split(SCells,",")
'enumarate by "1" point increment
for i = uBound(aCells) to 0 step -1
' using aCells Content
oCell = oSheet.getCellRangeByName(aCells(i))
oCharts = oSheet.getCharts()
' Get the chart with index 0, which is the first chart created
' to get the second you would use 1, the third 2 and so on...
oChart = oCharts.getByIndex(i)
oChartDoc = oChart.getEmbeddedObject()
'Change title
oChartDoc.getTitle().String = oCell.getString()
' xray oChart.Name
next i
End Sub
Related
I'm trying to CopyPicture cells in Column B, and name them the value in Column 1. I have code that works, except it keeps giving the pictures the wrong names. The baffling thing is that sometimes it works perfectly, and other times it does not.
I have tried to cobble together a routine based on posted examples of the CopyPicture command. I'm pasting it in below.
Yes, I'm a newbie at VBScript. Be gentle. ;-)
Sub makepic()
Dim path As String
path = "C:\BP\BP2020\JPGs\"
Dim CLen As Integer
Dim cntr As Integer
cntr = 1
Dim rgExp As Range
Dim CCntr As String
CString2 = "A1:A6"
Set rgExp2 = Range(CString2)
CString = "B1:B6"
Set rgExp = Range(CString)
For I = 1 To rgExp.Cells.Count Step 1
CCntr = rgExp2.Cells(I).Value
rgExp.Cells.Cells(I).Font.Size = 72
rgExp.Cells.Cells(I).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
rgExp.Cells.Cells(I).Font.Size = 14
''' Create an empty chart with exact size of range copied
CLen = Len(rgExp.Cells.Cells(I).Value)
CWidth = CLen * 85
With ActiveSheet.ChartObjects.Add(Left:=1600, Top:=rgExp.Top, _
Width:=CWidth, Height:=50)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
''' Paste into chart area, export to file, delete chart.
If CCntr <> "" Then
ActiveChart.Paste
Selection.Name = "pastedPic"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export (path + CCntr & ".jpg")
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
End If
cntr = cntr + 1
Next
End Sub
Again, I expect -- for example -- a picture of the contents of cell B1 to have the name of the contents of A1. I tried making the range A1:B4 (for example), but that got me 8 pictures. I finally decided to try to make 2 ranges, but that didn't work either.
I need to export the Catia Spec tree to use as a BoM.
The Export Should:
Go to Excel and will use the WalkDownTree function.
Have the PartNumber, Nomenclature and a User Added
Property called "Sinex Ref".
It will also have to make sure that the Exported Tree ignores Parts
and Products called "Ref".
Present the Quantity of each item using the
PartNumber.
Include the deactivated parts but mention that they
are deactivated.
I'm new to Catia and VBA and have come up with the following (I made adjustments to other macros that i have found but noticed that they ignore the children in the Tree). Currently the macro generates the Excel file and in the same cell cycles through all of the parts and children in the spec tree, regardless if they're deactivated or not.
Sub CATMain()
' ********* is the current document a CATIA Product **************
If CATIA.Documents.Count = 0 Then
MsgBox "There are no CATIA documents open. Please open a CATIA document and try again.", ,msgboxtext
Exit Sub
End If
If InStr(CATIA.ActiveDocument.Name, ".CATProduct") < 1 Then
MsgBox "The active document is not a Product. Please open a CATIA Product and try again.", ,msgboxtext
Exit Sub
End If
' ************* General declarations for the Active CATIA session *****************
Dim oProdDoc As ProductDocument
t = 1
Set oProdDoc = CATIA.ActiveDocument
Dim oRootProd As Product
Set oRootProd = oProdDoc.Product
Dim par As Parameters
Set par = oRootProd.UserRefProperties
Dim SinexRef As String
' *************** begin spec tree scroll ******************
Call WalkDownTree(oRootProd)
End Sub
Sub WalkDownTree(oInProduct As Product)
Dim oInstances As Products
Set oInstances = oInProduct.Products
On Error Resume Next
Set Excel = GetObject(, "EXCEL.Application")
If Err.Number <> 0 Then
Set Excel = CreateObject("EXCEL.Application")
Excel.Visible = True
Excel.Workbooks.Add
End If
If t <> 1 Then
for i=1 to oInProduct.Count
'**************************** Export title ***************************
row=2
col=1
Excel.Columns.Columns(1).Columnwidth = 5
Excel.Columns.Columns(2).Columnwidth = 15
Excel.Cells(row,col+1).Value = "CATProduct:"
Excel.Cells(row,col+1).Font.Bold = true
Excel.Cells(row,col+1).HorizontalAlignment = 3
Excel.Cells(row,col+2).Value = CATIA.ActiveDocument.Name
' **************************** Export column titles ***************
row=4
Excel.Cells(row,col+1).Value = "Instance Name"
Excel.Cells(row,col+1).Font.Bold = true
Excel.Columns.Columns(2).Columnwidth = 20
Excel.Cells(row,col+1).borders.LineStyle = 1
Excel.Cells(row,col+1).HorizontalAlignment = 3
Excel.Cells(row+2,col+1).Value = oInProduct.ReferenceProduct.PartNumber
Excel.Cells(row,col+2).Value = "Ref"
Excel.Cells(row,col+2).Font.Bold = true
Excel.Columns.Columns(3).Columnwidth = 15
Excel.Cells(row,col+2).borders.LineStyle = 1
Excel.Cells(row,col+2).HorizontalAlignment = 3
Excel.Cells(row+2,col+2).Value = oInProduct.ReferenceProduct.Nomenclature
Excel.Cells(row,col+3).Value = "Quantity"
Excel.Cells(row,col+3).Font.Bold = true
Excel.Columns.Columns(4).Columnwidth = 15
Excel.Cells(row,col+3).borders.LineStyle = 1
Excel.Cells(row,col+3).HorizontalAlignment = 3
Excel.Cells(row+2,col+3).Value = 1 'insert item quantity corresponding to PartNumber
Excel.Cells(row,col+4).Value = "SinexRef"
Excel.Cells(row,col+4).Font.Bold = true
Excel.Columns.Columns(5).Columnwidth = 15
Excel.Cells(row,col+4).borders.LineStyle = 1
Excel.Cells(row,col+4).HorizontalAlignment = 3
Excel.Cells(row+2,col+4).Value = 1 'insert Sinex Ref corresponding to PartNumber
t = t + 1
Next
End If
Dim k As Integer
For k = 1 To oInstances.Count
Dim oInst As Product
Set oInst = oInstances.Item(k)
Call WalkDownTree(oInst)
Next
End Sub
Assuming by
in the same cell cycles through all of the parts and children in the spec tree
you mean that it is writing/overwriting data from CATIA in the same cell, that is because you aren't incrementing anything regarding Excel rows/columns.
I personally would create headers for things like CATProduct, Instance Name, etc. then put pure data below instead of repeating these identical headers every single time, but your format will work as well, it might just be more difficult to summarize data in Excel.
Anyway, to maintain your existing format, you need to increment your Row at the end of your loop, around where t is incremented.
In the existing loop, it appears that rows 2-6 are used (5 rows total) for the first oInProduct. There is a row = 2 at the beginning of the loop which needs to be put just before the loop, this means it will start from the second row. There is also a row = 4 inside the loop which needs to be changed, we can use row = row + 2 to get the same effect. Then, at the end of the loop, we increment again to reach that total of 5, so use row = row + 3.
row = 2
for i = 1 to oInProduct.Count
'**************************** Export title ***************************
col=1
Excel.Columns.Columns(1).Columnwidth = 5
...
row = row + 2 'previously row = 4
...
Excel.Cells(row,col + 4).HorizontalAlignment = 3
Excel.Cells(row + 2,col + 4).Value = 1 'insert Sinex Ref corresponding to PartNumber
t = t + 1
row = row + 3
Next
Try
-->Analyze-->Bill of Material-->Define Format (for optional options)-->>Save as-->File format as .xls
Or:
-->File--> Save As --> Filetype:txt...Sure it's txt but maybe you can convert to .xls
(expecially if you have missing licenses)
I have used AssemblyConverter object which is available in Catia libraries to extract BOM.I found this when I recorded macro using the steps mentioned in above comment.
Try -->Analyze-->Bill of Material-->Define Format (for optional options)-->>Save as-->File format as .xls
I think this is the simplest and fast. Also, we can change format and location of file too.
Recorded Macro:
Sub CATMain()
Dim productDocument1 As ProductDocument
Set productDocument1 = CATIA.ActiveDocument
Dim product1 As Product
Set product1 = productDocument1.Product
Dim assemblyConvertor1 As AssemblyConvertor
Set assemblyConvertor1 = product1.GetItem("BillOfMaterial")
Dim arrayOfVariantOfBSTR1(4)
arrayOfVariantOfBSTR1(0) = "Quantity"
arrayOfVariantOfBSTR1(1) = "Part Number"
arrayOfVariantOfBSTR1(2) = "Type"
arrayOfVariantOfBSTR1(3) = "Nomenclature"
arrayOfVariantOfBSTR1(4) = "Revision"
Set assemblyConvertor1Variant = assemblyConvertor1
assemblyConvertor1Variant.SetCurrentFormat arrayOfVariantOfBSTR1
Dim arrayOfVariantOfBSTR2(1)
arrayOfVariantOfBSTR2(0) = "Quantity"
arrayOfVariantOfBSTR2(1) = "Part Number"
Set assemblyConvertor1Variant = assemblyConvertor1
assemblyConvertor1Variant.SetSecondaryFormat arrayOfVariantOfBSTR2
assemblyConvertor1.[Print] "XLS", "C:\Users\Desktop\BOM.xls", product1
End Sub
I have 3 sheets, in sheet one I have a column "Register Codes" and I have extracted the unique codes in next column. Please check the below image.
Based on these unique codes, sub-codes are allocated in sheet 2. please check the below image.
Now what I am trying here is that in sheet 3 I need every "Register code" with the relevant "sub-code" which is allocated in sheet2 based on the "unique ID" given in Sheet1. please check the below image for expected output.
I have been using various combinations of formulas but could not get a proper solution. What is the best way to do it in VBA as I just started learning in this field.
Subject to a few conditions the following code will do what you want. Install it in a standard code module (by default "Module1", but you can name it as you like) in the workbook where you have your data.
Option Explicit
Enum Nws ' Worksheet navigation
NwsFirstDataRow = 2 ' presumed the same for all worksheets
NwsCode = 1 ' 1 = column A (change as required)
NwsSubCode ' No value means previous + 1
NwsNumer
End Enum
Sub NumerList()
' 05 Apr 2017
Dim Wb As Workbook ' all sheets are in the same workbook
Dim WsCodes As Worksheet ' Register codes
Dim WsNum As Worksheet ' Sub-code values
Dim WsOut As Worksheet ' Output worksheet
Dim RegName As String, RegCode As String
Dim Sp() As String
Dim Rs As Long ' Source row in WsNum
Dim Rt As Long ' Target row in WsOut
Dim R As Long, Rl As Long ' rows / Last row in WsCodes
Set Wb = ActiveWorkbook ' Make sure it is active!
Set WsCodes = Wb.Worksheets("Reg Codes") ' Change name to your liking
Set WsNum = Wb.Worksheets("Code Values") ' Change name to your liking
On Error Resume Next
Set WsOut = Wb.Worksheets("Output") ' Change name to your liking
If Err Then
Set WsOut = Wb.Worksheets.Add(After:=WsNum)
WsOut.Name = "Output" ' create the worksheet if it doesn't exist
End If
On Error GoTo 0
Rt = NwsFirstDataRow
With WsCodes
Rl = .Cells(.Rows.Count, NwsCode).End(xlUp).Row
For R = NwsFirstDataRow To Rl
RegName = .Cells(R, NwsCode).Value
Sp = Split(RegName, "-")
If UBound(Sp) > 1 Then ' must find at least 2 dashes
RegCode = Trim(Sp(1))
Else
RegCode = ""
End If
If Len(RegCode) Then
On Error Resume Next
Rs = WorksheetFunction.Match(RegCode, WsNum.Columns(NwsCode), 0)
If Err Then Rs = 0
On Error GoTo 0
If Rs Then
Do
WsOut.Cells(Rt, NwsCode).Value = RegName
WsOut.Cells(Rt, NwsSubCode).Value = WsNum.Cells(Rs, NwsSubCode).Value
WsOut.Cells(Rt, NwsNumer).Value = WsNum.Cells(Rs, NwsNumer).Value
Rt = Rt + 1
Rs = Rs + 1
Loop While WsNum.Cells(Rs, NwsCode).Value = RegCode
Else
RegCode = ""
End If
End If
If Len(RegCode) = 0 Then
WsOut.Cells(Rt, NwsCode).Value = RegName
WsOut.Cells(Rt, NwsSubCode).Value = "No sub-code found"
Rt = Rt + 1
End If
Next R
End With
End Sub
And here are the conditions.
All 3 sheets must be in the same workbook. If you have them in different workbooks the code must be adapted to handle more than one workbook.
The two worksheets with data must exist. They must be named as the code prescribes or the code must be modified to match the names they have. The same goes for the Output worksheet, but that sheet will be created by the code if it doesn't exist. You can change its name in the code.
The enumeration at the top of the code presumes that all 3 sheets are identically formatted with no data in row 1 (captions) and data in columns A, B and C. Changes aren't difficult but must be made if you want a different input or output. You can change the columns in the existing code by assigning other values to the columns in the enum, but the code requires the same arrangement in all sheets.
The extracted codes in the Codes sheet aren't used. The code does its own extraction. It will mark an error in the output list if a code can't be extracted or if it isn't found in the Sub-code list.
The sub-codes in the Numer sheet must be sorted like the picture you posted. The code will look for the first occurrence of "image" and find the subcodes in the following rows while the code is "image" in column A. It will not find further occurrences of "image" that might follow after an intermission.
The code doesn't do any colouring. Adding it wouldn't be difficult, but you would have to specify some rules, such as "20 different colours for the first 20 codes and then repeat the same sequence".
Other cell formatting could be added without much effort because each cell is already individually named. More properties can be added easily.
I have a button that takes the data from a listbox and puts it into specific cells of my table. My problem right now is when inserting the value into the cells it fills the whole column that cell is in instead of the specific cell.
Here is the code for the button:
Private Sub cbSubmit_Click()
Dim i As Long
Dim v As Variant
Dim vTable() As Variant
Set inventoryTable = cSheet.ListObjects("inventory_table")
colItemID = inventoryTable.ListColumns("Item #").Index
colSpecs = inventoryTable.ListColumns("Specs").Index
v = inventoryTable.DataBodyRange.Rows
ReDim vTable(1 To UBound(v, 1), 1 To 4)
For i = 0 To lbItemList.ListCount - 1
vTable(i + 1, 1) = "=DATA!" & lbItemList.List(i, 2)
If specLink = "" Then
Exit For
Else
vTable(i + 1, 4) = lbItemList.List(i, 1)
End If
inventoryTable.DataBodyRange(i + 1, colItemID).Value = vTable(i + 1, 1)
inventoryTable.DataBodyRange(i + 1, colSpecs).Value = vTable(i + 1, 4)
Next
Unload Me
End Sub
This is how it looks after I run the button.
I want it to only fill in the first cell in Item # and then the cell in Specs in that same row. Then go down the rows each cell and fill in the next item. Instead each item gets filled overtop the old items.
If you are targeting individual cells in a structured table (aka ListObject object) then you need to turn of the AutoCorrect.AutoFillFormulasInLists property.
Application.AutoCorrect.AutoFillFormulasInLists = False
This can also be achieved with Alt+F,T,P, Alt+A then go to the AutoFormat As You Type tab and uncheck Fill formulas in tables to create calculated columns.
Optionally turn it back on at the end of your sub procedure if you wish to have this application-wide option available.
Application.AutoCorrect.AutoFillFormulasInLists = True
I need to reformat a XML file to .CSV.
I already opened the XML in Excel and did a little formating but now I really need to write a macro to get the data into shape. I already started bu I really have issues with the loop logic.
the List has a couple thousand Articles with a variable amount of subarticles.
each subarticle as a the same amount of properties but not every article has the same properties.
https://picload.org/image/ipialic/now.jpg
https://picload.org/image/ipialip/then.jpg
My Code up till now looks like this:
Option Explicit
Dim rowCount As Long, articleCount As Long, propertyCount As Integer, name As String
Sub Sortfunction()
rowCount = 1
articleCount = 0
propertyCount = 0
Do While Sheets("Test").Cells(rowCount, 1).Value <> "end"
If Cells(rowCount, 1).Value = "Reference" Then
rowCount = rowCount + 1
Do While Cells(rowCount, 3).Value = ""
If Cells(rowCount, 3).Value = "4" Then
End If
articleCount = articleCount + 1
Loop
articleCount = articleCount + 1
End If
rowCount = rowCount + 1
Loop
Sheets("result").Cells(1, 1).Value = rowCount
Sheets("result").Cells(2, 1).Value = articleCount
End Sub
At the end of the document i wrote the "end" to have a hook to stop the loop.
Can anyone provide some help? I'm really not the best programmer :-/
I'd really appreciate any help I can get :-)
here he's a translation into algorithm and some tips on functions
update: it was more tricky than I thought... I had to rewrite the code.
The main problem is "how to decide when change column".
I choose this solution "Each product in reference must have the same amount of properties".
If it's not the case, please indicate "how you decide when you have to create a new Column" (you can explain it in plain words)
Here the code rewrited. I tried it on your exemple, it work
Public Sub test()
' Set the range to navigate in your first sheet
Dim cell As Range: Set cell = Sheets("Feuil1").Range("A1")
' set the range to navigate in your result sheet
Dim res As Range: Set res = Nothing
' pos will be used to know the position of a product
Dim lastProperties As Range, posProperties As Range
' While the cell value is not "end"
Do While cell <> "end"
' if the cell is a reference
If cell = "Reference" Then
' Set the range of res
If res Is Nothing Then
Set res = Sheets("Feuil2").Range("A1")
Else
Set res = Sheets("Feuil2").Range("A" & lastProperties.offset(2).Row)
End If
' I set Offset(2) so you will have an empty line between 2 references
' Set the text of the new reference in the result
res = cell.offset(, 1) ' The reference is the cell 1 offset the right of the cell "Reference"
' WARNING : here no writing of titles anymore. It'll be done in the "Else".
' Here you just write "new reference" and reinit var
Else
' Here we have a property
' If the property alreay exist, consider it a new product in the reference
' When we are on a new property, the column of the product if the next to the right
If GetProperties(cell.offset(, 3), res, posProperties) Then
Set lastProperties = posProperties
End If
posProperties = cell.offset(, 4)
End If
' BIG FORGET: you have to get the next cell
Set cell = cell.offset(1)
Loop
End Sub
And the function to search / create your properties
Private Function GetProperties(ByVal propValues As String, ByVal start As Range, ByRef position As Range) As Boolean
Set position = start.offset(1)
' Is the cell below the properties ? Return the row below
' Search for the first "empty row" on the line
If position = propValues Then
Do
Set position = position.offset(, 1)
Loop While Trim(position) <> ""
' Indicate it's an existing value
GetProperties = True
Exit Function
End If
' Is the range empty ?
If Trim(position) = "" Then
' Create the new properties
position = propValues
Set position = position.offset(, 1)
GetProperties = False
Exit Function
End If
' Search the properties in the row below
GetProperties = GetProperties(propValues, position, position)
End Function
It should do the work. If you have any question on understanding some part, don't hesitate
if you don't know about Offset, some reading : https://msdn.microsoft.com/en-us/library/office/ff840060.aspx