I'm having one issue to perform a loop for 1 pivot table on excel file:
I just want to change the model2 from IJto CV
For i = 7 To 11
ActiveSheet.PivotTables("Tabela
dinâmica1").PivotFields("MODEL2").CurrentPage _
= "(All)"
With ActiveSheet.PivotTables("Tabela dinâmica1").PivotFields("MODEL2")
.PivotItems("CV").Visible = False
.PivotItems("IJ").Visible = True
.PivotItems("(blank)").Visible = False
End With
cel4 = "AV" & i
cel3 = "AX" & i
Worksheets("DDTZ C").Range("AZ" & i).Formula = "=Iferror(IF(" & cel4 &
"="""","""",VLookup(" & cel3 & ", AT:AV, 3, False)),"""")"
ActiveSheet.PivotTables("Tabela
dinâmica1").PivotFields("MODEL2").CurrentPage _
= "(All)"
With ActiveSheet.PivotTables("Tabela dinâmica1").PivotFields("MODEL2")
.PivotItems("CV").Visible = True
.PivotItems("IJ").Visible = False
.PivotItems("(blank)").Visible = False
End With
Worksheets("DDTZ C").Range("BA" & i).Value = "=Iferror(IF(" & cel4 &
"="""","""",VLookup(" & cel3 & ", AT:AV, 3, False)),"""")"
Next i
This loop has worked perfectly on first loop, however, when it start the second loop i = 8, an error appears to me, I have checked the script, and the problem is related to the followed part:
ActiveSheet.PivotTables("Tabela
dinâmica1").PivotFields("MODEL2").CurrentPage _
= "(All)"
With ActiveSheet.PivotTables("Tabela dinâmica1").PivotFields("MODEL2")
.PivotItems("CV").Visible = False
.PivotItems("IJ").Visible = True
.PivotItems("(blank)").Visible = False
End With
I cannot understand why I'm having a problem with that, since it works fine on the first loop i = 7
Anyone can help with that issue?
Thanks in advance
Try the code below.
Note: I've debugged only the PivotTable section, not the formula.
Dim PvtTbl As PivotTable
' set the Pivot Table into a variable
Set PvtTbl = ActiveSheet.PivotTables("Tabela dinâmica1")
Dim i As Long
For i = 7 To 11
With PvtTbl
With .PivotFields("MODEL2")
.ClearAllFilters
.PivotItems("CV").Visible = False
.PivotItems("(blank)").Visible = False
End With
cel4 = "AV" & i
cel3 = "AX" & i
' === Not debugging your formula part ===
Worksheets("DDTZ C").Range("AZ" & i).Formula = "=Iferror(IF(" & cel4 &
"="""","""",VLookup(" & cel3 & ", AT:AV, 3, False)),"""")"
With .PivotFields("MODEL2")
.ClearAllFilters
.PivotItems("IJ").Visible = False
.PivotItems("(blank)").Visible = False
End With
' === Not debugging your formula part ===
Worksheets("DDTZ C").Range("BA" & i).Value = "=Iferror(IF(" & cel4 &
"="""","""",VLookup(" & cel3 & ", AT:AV, 3, False)),"""")"
End With
Next i
Related
I've been struggling with the following code for the past weeks.
What it does is pretty simple, it allows me to retrieve data from multiple worksheets without opening them. The issue is that I have around 150 rows & 1700 columns of data to be filled thus around 255k cells of data... So it takes way too much time
The workbook looks like this:
Sub Worksheet_Change()
Dim Rng As Range
Dim r As Long
Dim s As String
Dim f As String
Dim i As Long
On Error GoTo ErrHandler
Dim m As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = False
m = Sheets("ECHEANCIER").Range("A" & Rows.Count).End(xlUp).Row
Range("I5:BMQ" & m).ClearContents
For r = 5 To m
For i = 9 To 1000
s = "'" & Range("B" & r).Value & "[" & Range("C" & r).Value & "]" & Range("D" & r).Value & "'!"
Sheets("ECHEANCIER").Cells(r, i).FormulaR1C1 = "=RC[-1]*(IF(ISNA(INDEX(" & s & " R1C1:R1000C1000,MATCH(R[" & 4 - r & "]C," & s & "C1,0),MATCH(RC7," & s & " R1,0)+1)),1,INDEX(" & s & " R1C1:R1000C1000,MATCH(R[" & 4 - r & "]C," & s & "C1,0),MATCH(RC7," & s & " R1,0)+1)))"
If Sheets("ECHEANCIER").Cells(r, i).Value = 0 Then
Sheets("ECHEANCIER").Cells(r, i).ClearContents
Exit For
End If
Range("I" & r & ":BMQ" & r).Copy
Range("I" & r & ":BMQ" & r).PasteSpecial Paste:=xlPasteValues
Next
Next
ExitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
I am also trying to having the formula already written instead of writting it VBA, but I understood that it is quite complicated and that you have to copy/paste as values in order to get the result but I don't get it.
Thanks a lot for your help!!!
I have this problem that my excel crash whenever I try to run my code.
I do believe I have a solution but I don't know how to execute it.
I have this code:
If (AnswerGame1A <> "") And (AnswerGame1B <> "") Then
Score1A.Visible = False
Score1B.Visible = False
Resultlist1.Visible = False
SubmitGame1.Visible = False
Dash1.Visible = False
GameLabel1.Visible = True
GameLabel1.Left = 36
End If
If (AnswerGame2A <> "") And (AnswerGame2B <> "") Then
Score2A.Visible = False
Score2B.Visible = False
Resultlist2.Visible = False
SubmitGame2.Visible = False
Dash2.Visible = False
GameLabel2.Visible = True
GameLabel2.Left = 36
End If
And this continues for another 51 times.
If I remove this code, the file does not chrash, My idea is to write a loop instead.
something like this, but this doesn't work.
INFO: all these names are controls within a multipage, that is within a userform. It is comboboxes, labels, commandbuttons and textboxes. The code run when the userform initialize.
For i = 1 to 51
If (Indirect("AnswerGame" & i & "A") <> "") And (Indirect("AnswerGame" & i & "B") <> "") Then
Indirect("Score" & i & "A").Visible = False
Indirect("Score" & i & "B").Visible = False
Indirect("Resultlist" & i).Visible = False
Indirect("SubmitGame" & i).Visible = False
Indirect("Dash" & i).Visible = False
Indirect("GameLabel" & i).Visible = True
Indirect("GameLabel" & i).Left = 36
End If
Next i
Do you think this could help excel from not crashing? and how can I fix the code to work?
Supposing that your combo boxes are of sheet ActiveX type, try the next code, please:
Sub testAvoitManyIterationsCombo()
Dim sh As Worksheet, i As Long
Set sh = ActiveSheet ' use here your necessary sheet
For i = 1 To 51
If sh.OLEObjects("AnswerGame" & i & "A").Object.Value <> "" And sh.OLEObjects("AnswerGame" & i & "B").Object.Value <> "" Then
sh.Shapes("Score" & i & "A").Visible = False
sh.Shapes("Score" & i & "B").Visible = False
sh.Shapes("Resultlist" & i).Visible = False
sh.Shapes("SubmitGame" & i).Visible = False
sh.Shapes("Dash" & i).Visible = False
sh.Shapes("GameLabel" & i).Visible = True
sh.Shapes("GameLabel" & i).left = 36
End If
Next i
End Sub
and if they are not activeX this should get you on track:
Option Explicit
Private Sub UserForm_Click()
Dim i As Long, str As String
For i = 1 To 10
str = "AnswerGame" & i & "A"
If Me.Controls(str).Value = "" Then
Score1A.Visible = False
End If
Next i
End Sub
My solution that works for my purpose. The file does not seem to crash anymore.
thank you #ceci for showing how to do it.
sorry for using "x" instead of "i", "i" is already being used elsewhere.
Dim x As Long, str1 As String, str2 As String, SCO1 As String, SCO2 As String, Res As String
Dim SubmitG As String, Da As String, GameL As String
For x = 1 To 51
str1 = "AnswerGame" & x & "A"
str2 = "AnswerGame" & x & "B"
If Me.Controls(str1) <> "" Then
If Me.Controls(str2) <> "" Then
SCO1 = "Score" & x & "A"
SCO2 = "Score" & x & "B"
Me.Controls(SCO1).Visible = False
Me.Controls(SCO2).Visible = False
Res = "Resultlist" & x
Me.Controls(Res).Visible = False
SubmitG = "SubmitGame" & x
Me.Controls(SubmitG).Visible = False
Da = "Dash" & x
Me.Controls(Da).Visible = False
GameL = "GameLabel" & x
Me.Controls(GameL).Visible = True
Me.Controls(GameL).Left = 36
End If
End If
Next x
Hi I have this macro and a few others that are similar that struggle when the worksheet names include "-", " ", "(" or ")". It normally fails on line when the graph series is created ActiveChart.FullSeriesCollection(1).XValues = "=" & ws.Name & "!$G$61:$G$" & iBas In the debugger when I hover over ws.Name it says Automation Error.
I have got around this by changing the worksheet names to remove these characters but I would like to understand why it fails and what if anything I can do to leave the worksheet names as they are?
Sub COREStepChart()
'
' Insert additional rows to have x value for base of core run in order to create bar/step shaped chart by depth/elevation and update graph series to new array
' Macro created by Dan Brenton 20200814
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Dim strRef, strRange As String
Dim iRow, iBase, iTCR, iSCR, iRQD, iDepthBase, iOrder As Integer
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
Select Case ws.Name
Case "Template", "Report", "Configuration (CORE)", "Configuration (Moisture)"
Case Else
ws.Name = Replace(ws.Name, "-", "")
ws.Name = Replace(ws.Name, " ", "")
ws.Name = Replace(ws.Name, "(", "")
ws.Name = Replace(ws.Name, ")", "")
ws.Activate
iTop = 61
iBase = 62
iLoca = 2
iDepthTop = 5
iDepthBase = 6
iTCR = 7
iSCR = 8
iRQD = 9
iOrder = 12
iElev = 17
Do While ws.Cells(iTop, iTCR) <> ""
Rows(iBase & ":" & iBase).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(iTop, iLoca), Cells(iTop, iElev)).Select
Selection.Copy
Cells(iBase, iLoca).Select
ActiveSheet.Paste
Cells(iTop, iDepthBase).Select
Selection.Copy
Cells(iBase, iDepthTop).Select
ActiveSheet.Paste
Cells(iTop, iOrder).Select
ActiveCell.FormulaR1C1 = "1"
Cells(iBase, iOrder).Select
ActiveCell.FormulaR1C1 = "2"
iTop = iTop + 2
iBase = iBase + 2
Loop
ActiveSheet.ChartObjects("Chart2").Activate
ActiveChart.PlotArea.Select
ActiveChart.FullSeriesCollection(1).XValues = "=" & ws.Name & "!$G$61:$G$" & iBase
ActiveChart.FullSeriesCollection(1).Values = "=" & ws.Name & "!$Q$61:$Q$" & iBase
ActiveChart.FullSeriesCollection(2).XValues = "=" & ws.Name & "!$H$61:$H$" & iBase
ActiveChart.FullSeriesCollection(2).Values = "=" & ws.Name & "!$Q$61:$Q$" & iBase
ActiveChart.FullSeriesCollection(3).XValues = "=" & ws.Name & "!$I$61:$I$" & iBase
ActiveChart.FullSeriesCollection(3).Values = "=" & ws.Name & "!$Q$61:$Q$" & iBase
ActiveSheet.ChartObjects("Chart5").Activate
ActiveChart.PlotArea.Select
ActiveChart.FullSeriesCollection(1).XValues = "=" & ws.Name & "!$G$61:$G$" & iBase
ActiveChart.FullSeriesCollection(1).Values = "=" & ws.Name & "!$E$61:$E$" & iBase
ActiveChart.FullSeriesCollection(2).XValues = "=" & ws.Name & "!$H$61:$H$" & iBase
ActiveChart.FullSeriesCollection(2).Values = "=" & ws.Name & "!$E$61:$E$" & iBase
ActiveChart.FullSeriesCollection(3).XValues = "=" & ws.Name & "!$I$61:$I$" & iBase
ActiveChart.FullSeriesCollection(3).Values = "=" & ws.Name & "!$E$61:$E$" & iBase
End Select
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I decided to learn VBA two weeks ago, and it's gone rather smooth. Now, however, I've encountered a problem I can't seem to solve on my own.
I've set up an excel document containing various modules. One of these modules extracts comments from a word document over to the excel sheet - which works as intended.
The problem is, I haven't been able to extract the first numbered header above each comment, which I'd very much like. Currently I have to do this manually after extracting the comments. As an example, I would like to also extract the first header and number above each comment, such as '2.1.1 Title'. If the comment is highlighting the header itself, it should be that header which is extracted as well.
I've tried a variety of things based on what I could find online, but every time I'm met with a variety of bugs I can't seem to fix. I've yet to find something that even sorta works. I did try one method which apparently should work in Word VBA, but I couldn't get it working within Excel.
Does anyone know how I would go about extracting the numbered headers? Any hints or tips will be greatly appreciated.
This is the code I have for the module:
Sub ImportCommentsDOCX()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim i As Integer
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
'1: if no comments'
With wdDoc
If wdDoc.Comments.Count = 0 Then
MsgBox ("No comments")
End If
'2; Set excel headers'
Range("B" & 1).Value = "Number"
Range("B" & 1).Font.Bold = True
Range("C" & 1).Value = "Comment"
Range("C" & 1).Font.Bold = True
Range("D" & 1).Value = "Highlighted text"
Range("D" & 1).Font.Bold = True
Range("E" & 1).Value = "Initials"
Range("B" & 1).Font.Bold = True
Range("F" & 1).Value = "Date (*Imprecise)"
Range("F" & 1).Font.Bold = True
'3: Extract comments and meta data'
For i = 1 To wdDoc.Comments.Count
Range("B" & 1 + i).Value = wdDoc.Comments(i).Index
Range("C" & 1 + i).Value = wdDoc.Comments(i).Range
Range("D" & 1 + i).Value = wdDoc.Comments(i).Scope.FormattedText
Range("E" & 1 + i).Value = wdDoc.Comments(i).Initial
Range("F" & 1 + i).Value = Format(wdDoc.Comments(i).Date, "dd/MM/yyyy") 'Unreliable: Sometimes gives wrong date'
'Range("G" & 3 + i).Value = wdDoc.Comments(i).Range.ListFormat.ListString 'Returns empty'
Next i
End With
Set wdDoc = Nothing
MsgBox ("Extraction has completed")
End Sub
Here is your code with some adjustments:
Sub ImportCommentsDOCX()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim i As Integer
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
'1: if no comments'
With wdDoc
wdDoc.Activate ' Added
If wdDoc.Comments.Count = 0 Then
MsgBox ("No comments")
End If
'2; Set excel headers'
Range("B" & 1).Value = "Number"
Range("B" & 1).Font.Bold = True
Range("C" & 1).Value = "Comment"
Range("C" & 1).Font.Bold = True
Range("D" & 1).Value = "Highlighted text"
Range("D" & 1).Font.Bold = True
Range("E" & 1).Value = "Initials"
Range("E" & 1).Font.Bold = True ' Modified
Range("F" & 1).Value = "Date (*Imprecise)"
Range("F" & 1).Font.Bold = True
'3: Extract comments and meta data'
For i = 1 To wdDoc.Comments.Count
Range("B" & 1 + i).Value = wdDoc.Comments(i).Index
Range("C" & 1 + i).Value = wdDoc.Comments(i).Range
Range("D" & 1 + i).Value = wdDoc.Comments(i).Scope.FormattedText
Range("E" & 1 + i).Value = wdDoc.Comments(i).Initial
Range("F" & 1 + i).Value = Format(wdDoc.Comments(i).Date, "dd/MM/yyyy") 'Unreliable: Sometimes gives wrong date'
'Range("G" & 1 + i).Value = wdDoc.Comments(i).Scope.ListFormat.ListString 'Returns empty' ' Modified ' Updated
Dim wp As Word.Paragraph: Set wp = wdDoc.Comments(i).Scope.Paragraphs(1) ' Updated
Do While wp.Range.ListFormat.ListString = "" ' Updated
Set wp = wp.Previous ' Updated
Loop ' Updated
Range("G" & 1 + i).Value = wp.Range.ListFormat.ListString ' Updated
Next i
End With
Set wdDoc = Nothing
MsgBox ("Extraction has completed")
End Sub
Please note my comments: Added and Modified
wdDoc.Activate was required at least on my computer, otherwise the
Range property is empty.
After initials a wrong column was bolded
The original text is referred to by the Range property, not the Scope (which is the content of the comment), so its ListFormat property should be used
The row index was not correct (3 instead of 1)
Looks working for me:
This requires Microsoft VBScript Regular Expression 5.5
Sub commentaires()
Dim regexOne As Object
Set regexOne = New RegExp
regexOne.Pattern = "^\d+\."
Dim s As String, s1 As String
Dim cmt As Word.Comment
Dim doc As Word.Document
For Each cmt In ActiveDocument.Comments
Dim wp As Word.Paragraph
Set wp = cmt.Scope.Paragraphs(1) ' Updated
Do While Not regexOne.Test(wp.Range.ListFormat.ListString)
Set wp = wp.Previous ' Updated
Loop ' Updated
s = s & _
wp.Range.ListFormat.ListString & ";" & _
cmt.Reference.Information(wdActiveEndAdjustedPageNumber) & ";""" & _
cmt.Scope & """;""" & _
cmt.Range.Text & """ " & vbCr
Next
Dim f As Integer
f = FreeFile
Open "c:\comments.csv" For Output As #f
Print #f, s
Close #f
End Sub
Im trying to create a pivot chart through VBA (So a button can create the pie chart based on dynamic values from a form)
My code is:
Dim iRow As Long
'//Find First Empty Row In Database
iRow = Sheets("search results").Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row
Sheets("Custom Chart").visible = True
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Search Results!A3:AM" & iRow, Version:=xlPivotTableVersion14). _
CreatePivotTable TableDestination:="Custom Chart!A1", TableName:="PivotTable6" _
, DefaultVersion:=xlPivotTableVersion14
Sheets("Custom Chart").Select
Cells(1, 1).Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Range("Custom Chart!$A$1:$C$18")
ActiveSheet.Shapes("Chart 1").IncrementLeft 192
ActiveSheet.Shapes("Chart 1").IncrementTop 15
ActiveSheet.PivotTables("PivotTable6").AddDataField ActiveSheet.PivotTables( _
"PivotTable6").PivotFields("Ethnicity Of Child"), "Count of Ethnicity Of Child" _
, xlCount
With ActiveSheet.PivotTables("PivotTable6").PivotFields(Me.Dy4.Value)
.Orientation = xlRowField
.Position = 1
End With
ActiveChart.ChartType = xlPie
ActiveChart.ApplyLayout (6)
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Chart Result"
ActiveWorkbook.ShowPivotTableFieldList = False
My code fails on this line:
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Search Results!A3:AM" & iRow, Version:=xlPivotTableVersion14). _
CreatePivotTable TableDestination:="Custom Chart!A1", TableName:="PivotTable6" _
, DefaultVersion:=xlPivotTableVersion14
Saying that a runtime 5 error has occurred. The only reason I can think of is that I'm trying to use cell references to define a range, I noticed that if you record creating a pivot chart, it uses ranges like Sheet1!R1C1, but I don't understand those references.
Any help would be appreciated.
Thanks in advance.
I fixed the problem myself,
Heres the complete code for generating a chart off of a form with variables:
Private Sub Creat_Chart_Click()
Worksheets.Add().Name = "Custom Chart"
If Me.R_End.Value = "" Or _
Me.R_Start.Value = "" Or _
Me.Chart_List.Value = "" Or _
Me.Data_List.Value = "" Or _
Me.Dy2.Value = "" Or _
Me.Dy4.Value = "" Then
MsgBox "Information is missing from the form"
Exit Sub
End If
Dim ws As Worksheet
Set ws = Worksheets("database")
Sheets("Settings").Range("Start_Date").Value = Format(Me.R_Start.Value, "mm/dd/yyyy")
Sheets("Settings").Range("End_Date").Value = Format(Me.R_End.Value, "mm/dd/yyyy")
'Collect Start & End Dates
Dim dStartDate As Long
Dim dEndDate As Long
dStartDate = Sheets("Settings").Range("Start_Date").Value
dEndDate = Sheets("Settings").Range("End_Date").Value
ws.Activate
'On Error GoTo error_Sdate:
RowNum = Application.WorksheetFunction.Match(dStartDate, Range("B1:B60000"), 0)
' MsgBox "Found " & Format(dStartDate, "dd/mm/yyyy") & " at row : " & RowNum
'On Error GoTo error_Edate:
RowNumEnd = Application.WorksheetFunction.Match(dEndDate, Range("B1:B60000"), 1)
' MsgBox "Found " & Format(dEndDate, "dd/mm/yyyy") & " at row : " & RowNumEnd
GoTo J1
error_Sdate:
Dim msg As String
msg = "You entered " & Format(dStartDate, "dd/mm/yyyy") & " as your Start Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the Start Date box"
MsgBox msg, , "Start Date Not Found"
Err.Clear
Exit Sub
error_Edate:
msg = "You entered " & Format(dEndDate, "dd/mm/yyyy") & " as your End Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the End Date box"
MsgBox msg, , "End Date Not Found"
Err.Clear
Exit Sub
J1:
Dim CR_1 As Integer
Dim CR1 As Integer
'// Get Criteria From Form And Search Database Headers
If Me.Data_List.Value = "Display Variable By Agency Of Referrer" Then
CR1 = 3
End If
If Me.Data_List.Value = "Display Variable By Agency Of Allegee" Then
CR1 = 4
End If
Set ws = Worksheets("database")
Set ps = Worksheets("Search Results")
ps.Range("A3:AM60000").Clear
'Dim RowNum As Variant
'Dim RowNumEnd As Variant
For i = RowNum To RowNumEnd
If ws.Cells(i, CR1).Value = Me.Dy2.Value Then
ws.Range("A" & i & ":AM" & i).Copy
ps.Activate
'find first empty row in database
emR = ps.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
ps.Range("A" & emR & ":AM" & emR).PasteSpecial
End If
Next i
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim rngSource As Range
Dim rngDest As Range
Dim LastRow As Long
Dim LastCol As Long
Set wksSource = Worksheets("Search Results")
Set wksDest = Worksheets("Custom Chart")
With wksSource
LastRow = .Range("A2").End(xlDown).Row
LastCol = .Range("A2").End(xlToRight).Column
Set rngSource = .Range("A2", .Cells(LastRow, LastCol))
End With
Set rngDest = wksDest.Range("A1")
wksDest.Activate
' If wksDest.PivotTables.count > 0 Then
'
'
' wksDest.Range("A:Z").Delete
'
'
' End If
ActiveSheet.PivotTableWizard _
SourceType:=xlDatabase, _
SourceData:=rngSource, _
TableDestination:=rngDest, _
TableName:="Pivotinfo"
With wksDest.PivotTables("Pivotinfo")
.PivotFields(Me.Dy4.Value).Orientation = xlRowField
.PivotFields(Me.Dy4.Value).Orientation = xlDataField
End With
Dim CC As Worksheet
Dim CCR, CCC As Long
Set CC = Sheets("Custom Chart")
CCR = CC.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row
CCC = CC.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column
Range("A1").Select
ActiveWorkbook.Charts.Add
ActiveChart.ChartType = xlPie
ActiveChart.ApplyLayout (4)
ActiveChart.SetElement (msoElementChartTitleAboveChart)
ActiveChart.SetElement (msoElementLegendRight)
ActiveChart.ApplyDataLabels
ActiveChart.SeriesCollection(1).DataLabels.Select
Selection.ShowPercentage = True
Selection.ShowCategoryName = False
Selection.Separator = "" & Chr(10) & ""
If CR1 = 3 Then
ActiveChart.ChartTitle.Characters.Text = Me.Dy4.Value & " Referred By " & Me.Dy2.Value & _
" Between The Dates " & Me.R_Start.Value & " & " & Me.R_End.Value
End If
If CR1 = 4 Then
ActiveChart.ChartTitle.Characters.Text = Me.Dy4.Value & " Referred By " & Me.Dy2.Value & _
" Between The Dates " & Me.R_Start.Value & " & " & Me.R_End.Value
End If
Application.DisplayAlerts = False
Worksheets("Custom Chart").Delete
Application.DisplayAlerts = True
End Sub
I got around the issue by deleting the custom chart sheet and re-creating it to get rid of the pivot table so I could create a new one with the same name. Not the tidiest method, but it works