To update pivot tables I use uno with this instruction:
dispatcher.executeDispatch(monDocUno, ".uno:RecalcPivotTable", "", 0, Array())
I would like not to use uno but the basic and its API to recalculate the pivot table of a calc sheet.
How we do that?
Just use the .refresh() method:
Sub refreshAllPilotTables
Dim oSheets As Variant
Dim oSheet As Variant
Dim oDataPilotTables As Variant
Dim oPilotTable As Variant
Dim i As Long
Dim j As Long
oSheets = ThisComponent.getSheets()
For i = 0 To oSheets.getCount()-1
oSheet = oSheets.getByIndex(i)
oDataPilotTables = oSheet.getDataPilotTables()
For j = 0 To oDataPilotTables.getCount()-1
oPilotTable = oDataPilotTables.getByIndex(j)
oPilotTable.refresh()
Next j
Next i
End Sub
Related
I have the following macro in a Calc file:
Dim oDoc as Object
oDoc=ThisComponent
Dim oSheets as Object
oSheets = oDoc.Sheets
Dim oController as Object
oController = oDoc.getCurrentController()
Dim numVisibleSheet
numVisibleSheet = oController.VisibleRange.Sheet
Dim currentSheet as Object
currentSheet = oController.ActiveSheet
currentSheet = oSheets.getByIndex(numVisibleSheet)
MsgBox "ok"
cell = currentSheet.getCellByPosition(5000, 5)
cell.setString("toto")
When I run it on LibreOffice 7, I get an 'outOfBoundsException' in cellsuno.cxx.
Is my use of getCellByPosition bad? Are there bounds on the x and y coordinates for a cell, and if so how can I expand these bounds?
Thanks!
I'm not so good with VBA, thus I'm suspecting an issue with declaring and later on using the dictionary.
I've taken a different approach. Created two functions to creat the dicts.
The for loop first is checking if the Control in userform is textbox, than is getting column number (dict_col) and checks if needs to be formatted as date (dict_for).
However each time the second dict seems to be empty... When I check content of each dict separately (before the loop), it shows correct values.
Public Function import_columns(rng As Variant) As Dictionary
Dim dict As New Dictionary
Dim i As Long
Dim count_rows As Long
Dim dict_k As String, dict_i As String
count_rows = rng.Rows.Count
For i = 1 To count_rows
dict_k = rng(i, 2)
dict_i = rng(i, 1)
dict.Add dict_k, dict_i
Next i
Set import_columns = dict
End Function
Public Function import_format(rng As Variant) As Dictionary
Dim dict_f As New Dictionary
Dim i As Long
Dim count_rows As Long
count_rows = rng.Rows.Count
For i = 1 To count_rows
dict_f(rng(i, 1)) = 0
Next i
Set import_format = dict_f
End Function
Private Sub UserForm_Initialize()
'On Error GoTo ErrorHandle
Dim wb As Workbook
Dim rng_col As Range
Dim rng_format As Range
Dim dc_value As Integer
Dim ctrl As Control
Dim ctrlType As String
Dim ctrl_name As String
Dim key As Variant
Dim dict_col As Dictionary
Dim dict_for As Dictionary
Set rng_col = Application.Union(Range("columns_mark").Columns(3), Range("columns_mark").Columns(2))
Set rng_format = Arkusz25.Range("H1").CurrentRegion
Set dict_col = import_columns(rng_col)
Set dict_for = import_format(rng_format)
'Me.Results.Enabled = False
ListBox1.RowSource = "lista"
txt_results = ListBox1.ListCount
For Each key In dict_col.Keys
'If dict_col.Exists(key) Then
Debug.Print key
Debug.Print dict_col(key)
'End If
Next key
ctrlType = "TextBox"
For Each ctrl In Results.Controls
ctrl_name = ctrl.Name
If TypeName(ctrl) = ctrlType Then
dc_value = dict_col(ctrl_name)
If dict_for.Exists(ctrl_name) Then
ctrl = Format(Val(ListBox1.List(0, dc_value - 1)), "dd.mm.yyyy")
Else
ctrl = ListBox1.List(0, dc_value - 1)
End If
ctrl.Enabled = False
End If
Next ctrl
Getting the above error on the Index/Match. Will try and keep this short and sweet but I am a VBA noob. Everything that is called has data in. One thing I noticed was that RefCol (a range of numbers) has leading and trailing whitespace when I do a Debug Print. However when I tested the length of the value it returned the correct values.
I can't understand what is breaking it, I did an index match in the workbook itself and it works perfectly.
Private Sub Ref_Change()
Dim ws As Worksheet
Dim tbl As ListObject
Set ws = Worksheets("Details")
Set tbl = ws.ListObjects("Call_Log")
Dim RefCol As Range
Dim NameCol As Range
Dim PhoneCol As Range
Dim DateCol As Range
Set RefCol = tbl.ListColumns("Ref Number").DataBodyRange
Set NameCol = tbl.ListColumns("Caller Name").DataBodyRange
Set PhoneCol = tbl.ListColumns("Telephone").DataBodyRange
Set DateCol = tbl.ListColumns("Date").DataBodyRange
Me.CallDate.Value = Application.WorksheetFunction.Index(DateCol, Application.Match(Me.Ref.Value, RefCol, 0))
End Sub
Have I set this up correctly?
Thanks
Evan
As stated most likely the Match is not being found and an error is being passed to the INDEX.
Pull the MATCH out and test for the error before finding the correct cell in the data.
Private Sub Ref_Change()
Dim ws As Worksheet
Dim tbl As ListObject
Set ws = Worksheets("Details")
Set tbl = ws.ListObjects("Call_Log")
Dim RefCol As Range
Dim NameCol As Range
Dim PhoneCol As Range
Dim DateCol As Range
Set RefCol = tbl.ListColumns("Ref Number").DataBodyRange
Set NameCol = tbl.ListColumns("Caller Name").DataBodyRange
Set PhoneCol = tbl.ListColumns("Telephone").DataBodyRange
Set DateCol = tbl.ListColumns("Date").DataBodyRange
Dim mtchRow As Long
mtchRow = 0
On Error Resume Next
mtchRow = Application.WorksheetFunction.Match(Me.ref.Value, RefCol, 0)
On Error GoTo 0
If mtchRow > 0 Then
Me.CallDate.Value = DateCol.Cells(mtchRow, 1).Value
Else
MsgBox "'" & Me.ref.Value & "' not found, or lookup array is more than one column or row"
End If
End Sub
I am trying to create a VB macro in Visio that can read the data and properties of the shape. So say I have a Rectangle Shpae in Visio with Cells Name, Description, Type, Size.... and so on.
When I try to read the cells and their values I am only getting the first cell and its value.
Here is my code . I would appreciate some help here.
Sub Testing()
Dim excelObj As Object
Dim excelFile As String
Dim sheetName As String
' Dim excelBook As Excel.Workbook
' Set excelFile = "C:\Users\hbhasin\Documents\test.xls"
'Set sheetName = "New Sheet name"
Set excelObj = CreateObject("Excel.Application")
excelObj.Workbooks.Add
Dim pagObj As Visio.Page
Dim shpsObj As Visio.shapes
Dim shapes As Visio.shapes
Dim shpObj As Visio.Shape
Dim CellObj As Visio.Cell
Dim Storage() As String
Dim iShapeCount As Integer
Dim i As Integer
Dim j As Integer
Set pagObj = ActivePage
Set shpsObj = pagObj.shapes
iShapeCount = shpsObj.Count
Debug.Print iShapeCount
ReDim Storage(8, iShapeCount - 1)
For i = 1 To iShapeCount - 1
Set shpObj = shpsObj(i)
Storage(1, i - 1) = shpObj.Name
If shpObj.CellExists("Prop.Name", visExistsLocally) Then
Set CellObj = shpObj.CellsU("Prop.Name")
Storage(2, i - 1) = CellObj.ResultStr("")
End If
If shpObj.CellExists("Prop.Description", visExistsLocally) Then
Debug.Print "Test the IF statement"
Set CellObj = shpObj.CellsU("Prop.Description")
Storage(3, i - 1) = CellObj.ResultStr("")
End If
Next
For i = 0 To iShapeCount - 1
Debug.Print "Name- " & Storage(0, i)
Debug.Print "Description-" & Storage(1, i)
Next
End Sub
In fact, I have put a debug statement within the second if clause and that does not execute which tells me the compiler is not even seeing the second cell or any cell after.
If you're not getting the Description Shape Data it maybe that it's not local, but inherited from its master. Here's a slight modification of your code (with the Excel part removed as I don't think it's relevant here):
Sub Testing()
Dim shpsObj As Visio.shapes
Set shpsObj = ActivePage.shapes
Dim iShapeCount As Integer
iShapeCount = shpsObj.Count
'Assumes you want an array of shape data
Dim Storage() As String
ReDim Storage(iShapeCount - 1, 2)
'Visio shapes are 1 based so use full count
Dim i As Integer
Dim shpObj As Visio.Shape
For i = 1 To iShapeCount
Set shpObj = shpsObj(i)
Storage(i - 1, 0) = shpObj.Name 'Do you want NameU?
'Assumes you don't care whether the cell is local or inherited
If shpObj.CellExistsU("Prop.Name", visExistsAnywhere) Then
Storage(i - 1, 1) = shpObj.CellsU("Prop.Name").ResultStr("")
End If
If shpObj.CellExistsU("Prop.Description", visExistsAnywhere) Then
Storage(i - 1, 2) = shpObj.CellsU("Prop.Description").ResultStr("")
End If
Next
Dim j As Long
For j = LBound(Storage, 1) To UBound(Storage, 1)
Debug.Print "Shape Name- " & Storage(j, 0)
Debug.Print " Prop.Name- " & Storage(j, 1)
Debug.Print " Prop.Description- " & Storage(j, 2)
Next j
End Sub
If you're just running through all the shapes on the page, then you might want to look at For Each shp In shapes as an alternative. Check out this page for more details:
http://visualsignals.typepad.co.uk/vislog/2007/11/looping-through.html
Also, you might want to try look at the CreateSelection page method to narrow down your target shapes if you're dealing with a large number
I have to compare the username from 2 workbooks in Excel using VBA. How does one do this?
For example :
In workbook 1 : column A contains 10 names
In workbook 2 : column A contains 10 names
I need to have the cell of column B in each workbook be colored Green or Red based on the match.
I "think" that you mean something like this, but I know I always need to be prudent.
The code below should work, but probably you will want to set the ranges more dynamically.
Option Explicit
Sub Compare_Names()
Dim oBook_1 As Excel.Workbook
Dim oBook_2 As Excel.Workbook
Dim oRange_1 As Range
Dim iRange_1_Rows As Integer
Dim oRange_2 As Range
Dim iRange_2_Rows As Integer
Dim vArray As Variant
Dim vArray_Found As Variant
Dim iCnt As Integer
Dim iCnt_B As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set oBook_1 = Workbooks.Open("U:/Names_1.xls")
Set oRange_1 = oBook_1.Sheets(1).Range("A1:A5") 'Can be dynamically set when needed
iRange_1_Rows = oRange_1.Rows.Count
ReDim vArray(1 To iRange_1_Rows, 1 To 1)
vArray = oRange_1
Set oRange_1 = Nothing
oBook_1.Close
Set oBook_1 = Nothing
Set oBook_2 = Workbooks.Open("U:/Names_2.xls")
Set oRange_2 = oBook_2.Sheets(1).Range("A1:A5")
iRange_2_Rows = oRange_2.Rows.Count
For iCnt = 1 To iRange_1_Rows
For iCnt_B = 1 To iRange_2_Rows
ReDim vArray_Found(1 To iRange_2_Rows, 1 To 1)
If Trim(vArray(iCnt, 1)) = Trim(oRange_2(iCnt_B)) Then
oRange_2(iCnt_B).Interior.Color = vbGreen
vArray(iCnt_B, 1) = True
End If
Next iCnt_B
Next iCnt
For iCnt = 1 To iRange_2_Rows
If vArray(iCnt, 1) <> True Then
oRange_2(iCnt).Interior.Color = vbRed
End If
Next iCnt
Set oRange_2 = Nothing
oBook_2.Save
oBook_2.Close
Set oBook_2 = Nothing
End Sub
If you want a non-case sensitive comparison you can use:
if UCase(Trim(vArray(iCnt, 1))) = UCase(Trim(oRange_2(iCnt_B))) Then