I've been trying to figure out what i'm doing wrong but I can't find the answer. I've got the following code:
Sub CreatePivotChart()
Dim sh As Shape
Dim ws As Worksheet
Dim ch As Chart
Dim pt As PivotTable
DeleteAllChartObjects
'setting ws and sh will be done alot here. It's basically making it easy for yourself by making a new (short name):
Set ws = Worksheets("Analysis")
Set sh = ws.Shapes.AddChart(XlChartType:=xlColumn, Width:=400, Height:=200)
'This part to make sure that when there's no cell selected when running the code) within the pivottable, it still works
Set ch = sh.Chart
'Acipivot is created as title for the pivottable in sbCreativpivot:
Set pt = Worksheets("PivotTable").PivotTables("Acpivot")
ch.SetSourceData pt.TableRange1
'align the chart with the table:
sh.Top = pt.TableRange1.Top
sh.Left = pt.TableRange1.Left + pt.TableRange1.Width + 10
End Sub
Everything works fine, except I can't name the chart. I've tried several methods that I found online, but none of them seem to work.
Here's my latest attempt:
'This part to make sure that when there's no cell selected when running the code) within the pivottable, it still works
Set ch = sh.Chart
With ch
With .Parent.Name = "test"
End With
End With
But if I then try to reference it like here:
Sub EditPivotChart()
Dim pt As PivotTable
Dim ch As Chart
Dim pf As PivotField
Set ch = Charts("test")
Set pt = ch.PivotLayout.PivotTable
For Each pf In pt.VisibleFields
pf.Orientation = xlHidden
Next pf
End Sub
I get an error
vba ran out of memory
Does anyone see what wrong I am doing?
Thanks!
You can remove all of the following segment
With ch
With .Parent.Name = "test"
End With
End With
and simply replace it with
sh.Name = "test"
That should do the trick.
Related
I have run into trouble writing a code in VBA that will allow me to describe a range of non-consecutive cells when one of those cells is a variable. When I run this line of code I get an error at the line beginning with Range(copyToRange) = Application.WorksheetFunction.Average(copyFromRange). Sorry if this is a simple fix, I've been banging my head against a wall all day:
Sub GetPCData()
'Get PC response ratios
PCanalytes = Array("Furosemide", "Caffeine", "Ketoprofen", "Phenylbutazone", "Flunixin")
PCanalytePositions = Array("J32", "J33", "J34", "J35", "J36")
Set SQWorkbook = Application.ActiveWorkbook
Dim sourceSheet, targetSheet As Worksheet
Dim copyFromRange, copyToRange As Range
Dim Y As Range
Set targetSheet = ThisWorkbook.Sheets("QC data")
For i = 0 To SQWorkbook.Worksheets.Count
Set sourceSheet = SQWorkbook.Worksheets(PCanalytes(i))
Set Y = sourceSheet.Range("A7").End(xlDown)
Set copyToRange = targetSheet.Range(PCanalytePositions(i))
Set copyFromRange = sourceSheet.Range(("H8"), Y.Offset(0, 7))
Range(copyToRange) = Application.WorksheetFunction.Average(copyFromRange)
Next i
End Sub
Incorrect syntax!
Try this:
copyToRange.Value = Application.WorksheetFunction.Average(copyFromRange)
Why?, because you are telling Excel "copyToRange" is a RANGE already:
Dim copyFromRange, copyToRange As Range
Hope this help you.
I am trying to create a chart on my sheet Monthprepare.
I am using the below code.
I have the code , behind the button with several other calling functions.
The problem is, whenever I am creating the chart, it is creating them twice.
I am left confused what would be the reason.
Could someone help to figure it out.
Sub chartmonthprep()
Dim cht As Chart
Dim stable As PivotTable
Dim pt, sh
If ActiveSheet.PivotTables.count = 0 Then Exit Sub
Set stable = ActiveSheet.PivotTables(2)
Set pt = stable.TableRange1
Set sh = ActiveSheet.ChartObjects.Add(Left:=250, _
Width:=400, Top:=20, Height:=250)
sh.Select
Set cht = ActiveChart
With cht
.SetSourceData pt
.ChartType = xlColumnStacked
End With
cht.FullSeriesCollection(1).Name = "Average of Red"
cht.SeriesCollection(1).HasDataLabels = True
cht.SeriesCollection(2).HasDataLabels = True
cht.SeriesCollection(1).Format.Fill.ForeColor.RGB = RGB(0, 255, 0)
cht.SeriesCollection(2).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
cht.HasTitle = True
cht.ChartTitle.Text = " Result"
End Sub
Try like this:
Sub chartmonthprep()
If ActiveSheet.ChartObjects.Count > 1 Then Exit Sub
'the rest of your code here --v
Dim cht As Chart
Dim stable As PivotTable
End Sub
It will make sure that it is only 1 chart.
You can loop for each Pivot Table in a sheet with this:
Sub PivotTable()
Dim sh As Worksheet
Dim pvt As PivotTable
Set sh = ThisWorkbook.Sheets("Sheet1")
For Each pvt In sh.PivotTables
MsgBox pvt.Name
'do something
Next pvt
End Sub
I have a pivot table, and I am trying to select certain pivot items based on values in an array. I need this process to go faster, so I have tried using Application.Calculation = xlCalculationManual and PivotTables.ManualUpdate = True, but neither seem to be working; the pivot table still recalculates each time I change a pivot item.
Is there something I can do differently to prevent Excel from recalculating each time?
Or is there a way to deselect all items at once (not individually) to make the process go quicker?
Here is my code:
Application.Calculation = xlCalculationManual
'code to fill array with list of companies goes here
Dim PT As Excel.PivotTable
Set PT = Sheets("LE Pivot Table").PivotTables("PivotTable1")
Sheets("LE Pivot Table").PivotTables("PivotTable1").ManualUpdate = True
Dim pivItem As PivotItem
'compare pivot items to array.
'If pivot item matches an element of the array, make it visible=true,
'otherwise, make it visible=false
For Each pivItem In PT.PivotFields("company").PivotItems
pivItem.Visible = False 'initially make item unchecked
For Each company In ArrayOfCompanies()
If pivItem.Value = company Then
pivItem.Visible = True
End If
Next company
Next pivItem
It seems that you really want to try something different to significantly reduce the time it takes to select the required items in pivotttable.
I propose to use a “MirrorField”, i.e. a copy of the “Company” to be used to set in the sourcedata of the pivottable the items you need to hide\show.
First you need to add manually (or programmatically) the “MirrorField” and named same as the source field with a special character at the beginning like “!Company” the item must be part of the sourcedata and it can be placed in any column of it (as this will a “programmer” field I would place it in the last column and probably hidden as to not creating any issues for\with the users)
Please find below the code to update the pivottable datasource and to refresh the pivottable
I’m also requesting the PivotField to be updated just make it flexible as it then can be used for any field (provided that the “FieldMirror” is already created)
Last: In case you are running any events in the pivottable worksheet they should be disable and enable only to run with the last pivottable update
Hope this is what you are looking for.
Sub Ptb_ShowPivotItems_MirrorField(vPtbFld As Variant, aPtbItmSelection As Variant)
Dim oPtb As PivotTable
Dim rPtbSrc As Range
Dim iCol(2) As Integer
Dim sRC(2) As String
Dim sFmlR1C1 As String
Dim sPtbSrcDta As String
Rem Set PivotTable & SourceData
Set oPtb = ActiveSheet.PivotTables(1)
sPtbSrcDta = Chr(34) & oPtb.SourceData & Chr(34)
Set rPtbSrc = Evaluate("=INDIRECT(" & sPtbSrcDta & ",0)")
Rem Get FieldMirrow Position in Pivottable SourceData (FieldMirrow Already present SourceData)
With rPtbSrc
iCol(1) = -1 + .Column + Application.Match(vPtbFld, .Rows(1), 0)
iCol(2) = Application.Match("!" & vPtbFld, .Rows(1), 0)
End With
Rem Set FieldMirror Items PivotTable SourceData as per User Selection
sRC(1) = """|""&RC" & iCol(1) & "&""|"""
sRC(2) = """|" & Join(aPtbItmSelection, "|") & "|"""
sFmlR1C1 = "=IF(ISERROR(SEARCH(" & sRC(1) & "," & sRC(2) & ")),""N/A"",""Show"")"
With rPtbSrc.Offset(1).Resize(-1 + rPtbSrc.Rows.Count).Columns(iCol(2))
.Value = "N/A"
.FormulaR1C1 = sFmlR1C1
.Value = .Value2
End With
Rem Refresh PivotTable & Select FieldMirror Items
With oPtb
Rem Optional: Disable Events - In case you are running any events in the pivottable worksheet
Application.EnableEvents = False
.ClearAllFilters
.PivotCache.Refresh
With .PivotFields("!" & vPtbFld)
.Orientation = xlPageField
.EnableMultiplePageItems = False
Rem Optional: Enable Events - To triggrer the pivottable worksheet events only with last update
Application.EnableEvents = True
.CurrentPage = "Show"
End With: End With
End Sub
It seems unavoidable to have the pivotable refreshed every time a pivotitem is updated.
However I tried approaching the problem from the opposite angle. i.e.:
1.Validating the “PivotItems to be hidden” before updating the pivottable.
2.Also making make all items visible at once instead of “initially make item unchecked” one by one.
3.Then hiding all the items not selected by the user (PivotItems to be hidden)
I ran a test with 6 companies selected out of a total of 11 and the pivottable was updated 7 times
Ran also your original code with the same situation and the pivottable was updated 16 times
Find below the code
Sub Ptb_ShowPivotItems(aPtbItmSelection As Variant)
Dim oPtb As PivotTable
Dim oPtbItm As PivotItem
Dim aPtbItms() As PivotItem
Dim vPtbItm As Variant
Dim bPtbItm As Boolean
Dim bCnt As Byte
Set oPtb = ActiveSheet.PivotTables(1)
bCnt = 0
With oPtb.PivotFields("Company")
ReDim Preserve aPtbItms(.PivotItems.Count)
For Each oPtbItm In .PivotItems
bPtbItm = False
For Each vPtbItm In aPtbItmSelection
If oPtbItm.Name = vPtbItm Then
bPtbItm = True
Exit For
End If: Next
If Not (bPtbItm) Then
bCnt = 1 + bCnt
Set aPtbItms(bCnt) = oPtbItm
End If
Next
ReDim Preserve aPtbItms(bCnt)
.ClearAllFilters
For Each vPtbItm In aPtbItms
vPtbItm.Visible = False
Next
End With
End Sub
Below is a macro for Excel2010 in VBA. It's working only when I open VBA Code editor and run from the menu Debug. I tried to put it to Ribbon and run it from there but I've got this error:
Run-time error '1004':
Application-defined or object-defined error
Additionally, when I change all Range() into .Worksheet(i).Range(), the procedure does not run at all with the same error. It's like .Range does not seem to be part of Worksheet(i). I have no experience in Excel 2010 VBA.
Sub CopyAndRearrange()
Dim ns As Integer
Dim i As Integer
ns = ActiveWorkbook.Worksheets.Count
ActiveWorkbook.Sheets(ns).Cells.ClearContents
For i = 1 To ns - 1
With ActiveWorkbook
.Worksheets(i).Activate
Range("E1") = CInt(.Worksheets(i).Name)
Range(Range("G1"), Range("A1").End(xlDown).Offset(0, 7)) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5"
Range(Range("I1"), Range("A1").End(xlDown).Offset(0, 8)) = "=RC[-6]"
Range(Range("G1"), Range("I1").End(xlDown)).Copy
Sheets(ns).Activate
If i = 1 Then
'Range(Range("G1"), Range("I1").End(xlDown)).Copy Destination:=Sheets(ns).Range("A1")
Sheets(ns).Range("A1").Select
Else
'Range(Range("G1"), Range("I1").End(xlDown)).Copy Destination:=Sheets(ns).Range("A1").End(xlDown).Offset(1, 0)
Sheets(ns).Range("A1").End(xlDown).Offset(1, 0).Select
End If
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
Next
Sheets(ns).Range("A1").Select
End Sub
EDIT:
OK. I have slightly changed the code in hope I was wrong about referring to the right sheet etc. The problem is still there. The line: ActiveSheet.Range(rg1, rg1) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5" causes the problem. Surprisingly, it is not the first that I refer to Range in the an active sheet and for some reasons, I really don't know why, I've got the error!!! To exhaust all possibilities, I have also tried these:
Explicitly re-create a Module in VBA Window
Re-open the file
Record a macro and insert a code in there
Nothing's worked so far. I have given up but maybe someone in future will see the problem and give a solution here.
Public Sub CopyAndRearrange()
Dim ns As Integer
Dim i As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim rg1 As Range
Dim rg2 As Range
Dim cell As Range
Set wb = ThisWorkbook
ns = wb.Worksheets.Count
wb.Sheets(ns).Cells.ClearContents
For i = 1 To ns - 1
With wb
Set ws = wb.Worksheets(i)
ws.Activate
ActiveSheet.Range("E1") = CInt(ActiveSheet.Name)
Set rg1 = ActiveSheet.Range("G1")
Set rg2 = ActiveSheet.Range("A1").End(xlDown).Offset(0, 7)
ActiveSheet.Range(rg1, rg1) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5"
Set rg1 = ActiveSheet.Range("I1")
Set rg2 = ActiveSheet.Range("A1").End(xlDown).Offset(0, 8)
ActiveSheet.Range(rg1, rg2) = "=RC[-6]"
Set rg1 = ActiveSheet.Range("G1")
Set rg2 = ActiveSheet.Range("I1").End(xlDown)
ActiveSheet.Range(rg1, rg2).Copy
Sheets(ns).Activate
If i = 1 Then
ActiveSheet.Range("A1").Select
Else
ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
End If
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
Next
Sheets(ns).Range("A1").Select
Set ws = Nothing
Set wb = Nothing
Set rg1 = Nothing
Set rg2 = Nothing
Set cell = Nothing
End Sub
Try the following:
Sub CopyAndRearrange(Control as IRibbionControl)
Adding the control allows the code to be executed from the ribbion.
I guess I found the answer to my own question.
The problem was missing bracket in this line:
ActiveSheet.Range(rg1, rg1) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5"
which should be:
ActiveSheet.Range(rg1, rg1) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5)"
If the error was more intelligible, I would not lose 2 days to look for this problem :/
I have the following code, which opens an excel file, selects the sheet and runs a macro - I have then managed to make it remove the filter for Date, but I am then having trouble getting it to filter to "01/07/2013"
Sub Data()
Dim oExcel As Excel.Application
Dim oWB As Workbook
Dim oSheets As Sheets
Dim oPi As PivotItem
Set oExcel = New Excel.Application
oExcel.Workbooks.Open ("\\A79APBRSFACTD\MDSS\FactivityServer\FactShar\OEE_Daily2.xls")
oExcel.Visible = True
Set oExcel = Excel.Application
Set oWB = oExcel.Workbooks("OEE_Daily2.xls")
oWB.Sheets("OEE Pivot Daily").Select
oExcel.Run ("Update_OEE_Daily")
oWB.Sheets("OEE Pivot Daily").Range("B3").Select
With oWB.Sheets("OEE Pivot Daily").PivotTables("PivotTable2").PivotFields("Date")
.ClearAllFilters
.PivotItems("01/07/2013").Visible = True
End With
Set oExcel = Nothing
Set oWB = Nothing
End Sub
I receive the following error message Run-time error '1004': Unable to get the PivotItems property of the PivotField class
The date "01/07/2013" is available in the source data of the PivotTable, and I am able to select it manually, but not automatically.
This is baffling me, as I only need it to show the one date.
If you're trying to show only 01/07/2013, then once you've cleared the filter, you need to hide everything except 01/07/2013, so try this:
With oWB.Sheets("OEE Pivot Daily").PivotTables("PivotTable2").PivotFields("Date")
.ClearAllFilters
For Each oPi In .PivotItems
If oPi .Value <> "1/7/2013" Then
oPi .Visible = False
End If
Next pi
End With
Make sure you remove the zeros.
If you step through your code, and watch oPi.value, you will see that it is "1/7/2013" instead of "01/07/2013". At least it was for me.
Excel is a nightmare when it comes to regional dates, so if you are using US mm/dd/yyyy format, this should work. If you're using dd/mm/yyyy format, you will need to check oPi.value against an American-formatted date. Annoyingly.
Edited 23/07/2013:
New code to search the data before applying the filter and lots of re-formatting to get around the American date format issue:
Sub RunFilter()
Dim strFilterDate As String
Dim datFilterDate As Date
Dim rngDateRange As Range
Dim c As Range
strFilterDate = InputBox("Enter the filter date in dd/mm/yyyy format.", "Enter date", Format(Now(), "dd/mm/yyyy"))
If IsDate(strFilterDate) And Len(strFilterDate) = 10 Then
datFilterDate = DateSerial(Right(strFilterDate, 4), Mid(strFilterDate, 4, 2), Left(strFilterDate, 2))
Set rngDateRange = ThisWorkbook.Worksheets("Sheet1").Range("B:B").SpecialCells(xlCellTypeConstants)
For Each c In rngDateRange
If c.Value2 = datFilterDate Then
ApplyPTFilter (datFilterDate)
Exit For
End If
Next c
End If
End Sub
Sub ApplyPTFilter(datDate As Date)
Dim pi As PivotItem
Dim strDate As String
strDate = Format(datDate, "m/d/yyyy")
With ThisWorkbook.Sheets("OEE Pivot Daily").PivotTables("PivotTable2").PivotFields("Date")
.ClearAllFilters
For Each pi In .PivotItems
If pi.Value <> strDate Then
pi.Visible = False
End If
Next pi
End With
End Sub
I realize that I bumped on similar issue waaay after the original post, although this thread was very inspiring - what helped me was:
.PivotCache.MissingItemsLimit = xlMissingItemsNone
After clearing the retained items from the pivotfilter list - I managed to execute my code without fail, what went after this was:
FiltrArr = Array("wymagalne", "wymagalne na jutro", "przeterminowane", "puste")
For Each PivotItem In .PivotFields("status").PivotItems
If Not IsError(Application.Match(PivotItem.Caption, FiltrArr, 0)) Then
PivotItem.Visible = True
Else
PivotItem.Visible = False
End If
Next PivotItem