I've been trying below code to copy chart as picture, and paste it in another sheet without selection/activate. however it does not seem to paste the picture into the range:
Dim Range_DriverLookup As Range, RowCounter_DriverLookup As Long
Dim Count_DeliveredServicesNumber As Long, Counter_DeliveredServicesNumber As Long
Dim Cht_SitePotential As ChartObject
Dim Cht_Top5 As ChartObject
Dim Cht_RegionalPeerGroup As ChartObject
Dim PvtTbl_SitePotential As PivotTable
Dim PvtTbl_Top5 As PivotTable
Dim PvtTbl_RegionalPeerGroup As PivotTable
Dim Graph_PerformanceReport As Excel.Picture
'''''''''''''''''''''''''''''''''''''''''
' Assign ranges, pivottables and charts '
'''''''''''''''''''''''''''''''''''''''''
Set Range_DriverLookup = ThisWorkbook.Worksheets(SheetDriverLookup.Name).ListObjects("DriverLookup").DataBodyRange
Set PvtTbl_SitePotential = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).PivotTables("PivotTableSitePotential")
Set PvtTbl_Top5 = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).PivotTables("PivotTableTop5")
Set PvtTbl_RegionalPeerGroup = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).PivotTables("PivotTableRegionalPeerGroup")
Set Cht_SitePotential = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).ChartObjects("ChartSitePotential")
Set Cht_Top5 = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).ChartObjects("ChartTop5")
Set Cht_RegionalPeerGroup = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).ChartObjects("ChartRegionalPeerGroup")
'''''''''''''''''''''''''''''''''''
' Initiate new performance report '
'''''''''''''''''''''''''''''''''''
'// Clear previous graphs
For Each Graph_PerformanceReport In ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Pictures
Graph_PerformanceReport.Delete
Next Graph_PerformanceReport
'// Clear previous sheet setup, and initiate new
Stop
With ThisWorkbook.Worksheets(SheetPerformanceReport.Name)
'/ Unhide rows in PerformanceReport
.Cells.EntireRow.Hidden = False
'/ Clear previous "table of content"
.Range("TableOfContent").ClearContents
'/ Reset pagebreaks and set for new frontpage
.ResetAllPageBreaks
.Rows(71).PageBreak = xlPageBreakManual
End With
'// Set filters on frontpage graph
PvtTbl_SitePotential.ClearAllFilters
PvtTbl_SitePotential.PivotFields("Serviceline").AutoSort Order:=xlDescending, Field:="Potential Savings (Yearly) "
PvtTbl_SitePotential.PivotFields("Serviceline").ShowDetail = False
PvtTbl_SitePotential.PivotFields("Site").PivotFilters.Add Type:=xlCaptionEquals, Value1:=ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Range("Site").Value
PvtTbl_SitePotential.PivotFields("Serviceline").PivotFilters.Add _
Type:=xlValueIsGreaterThanOrEqualTo, DataField:=PvtTbl_SitePotential.PivotFields("Potential Savings (Yearly) "), Value1:=5000
'// Create title for frontpage graph
With Cht_SitePotential.Chart.ChartTitle
.Caption = ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Range("Site") & " - Yearly Potential on Service Level"
End With
'// Paste frontpagegraph to PerformanceReport
With Cht_SitePotential.Chart
.ChartArea.Copy
End With
ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Range("D7:D7").PasteSpecial xlPasteValues
Edited with larger part of the code.
I'ts working for me when I simulated .Range("Frontpage_Graph") with "P1:P1"
ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Range("P1:P1").PasteSpecial ppPasteEnhancedMetafile
ppPasteEnhancedMetafile will give a better resolution chart picture.
If you use a range like "P10:Z20" it will just use P10 as the anchor point of the Chart picture.
Related
I want to resize a chart table in PowerPoint via VBA. I've read the following solution multiple times (Resize Listobject Table dynamically with VBA) and it does seem precisely what I need, but for some reason (maybe because I'm running the macro from PowerPoint) it gives me the following error: Automation error (Error 440).
I plan to use the Resize method because I'm updating a PPT chart data table from another Excel file without using the .Activate method (I opted to not use the .Activate because it opened many charts workbooks after the Macro finished execution, even with multiple Waits and Excel.Application.Quit and .Close).
It works great, the charts workbooks do not flash on the screen and the values are copied fast, BUT... the table size is not correct. It only includes the 1st line of the ppt chart data table, and thus my chart is rendered incomplete.
Dim Line As Range Dim financialPartner As String, financialProject As String
financialPartner = excl.Workbooks("HNK-Status-CDAU.xlsx").Sheets("Financial").Cells(int_lin, 2)
financialProject = excl.Workbooks("HNK-Status-CDAU.xlsx").Sheets("Financial").Cells(int_lin, 3)
Dim found As Boolean
found = False
Dim lastRow As Long
Dim financialChart As Chart
Dim financialChartData As Range
Dim financialChartTable As ListObject
Dim financialChartTablews As Worksheet
lastRow = ActiveWindow.Selection.SlideRange.Shapes("RevenuesVolume").Chart.chartData.Workbook.Sheets(1).Range("A1048576").End(xlUp).Row
Set financialChart = ActiveWindow.Selection.SlideRange.Shapes("RevenuesVolume").Chart
Set financialChartTablews = ActiveWindow.Selection.SlideRange.Shapes("RevenuesVolume").Chart.chartData.Workbook.Worksheets(1)
Set financialChartTable = financialChartTablews.ListObjects("Tabela1")
For Each Line In chartDataTable.DataBodyRange.Rows
Dim lineNumber As Long
lineNumber = Line.Row
If ((Line.Columns(1) <> financialPartner) Or (Line.Columns(2) <> financialProject)) And found Then
Exit For
End If
If (Line.Columns(1) = financialPartner) And (Line.Columns(2) = financialProject) Then
found = True
With financialChart.chartData
Set financialChartData = .Workbook.Worksheets(1).ListObjects(1).Range
financialChartData.Range("A" & lastRow).Value = chartDataWs.Cells(lineNumber, 4)
financialChartData.Range("B" & lastRow).Value = chartDataWs.Cells(lineNumber, 5)
financialChartData.Range("C" & lastRow).Value = chartDataWs.Cells(lineNumber, 6)
lastRow = lastRow + 1
financialChartTable.Resize Range("A1:C" & lastRow)
.Workbook.Close
End With
End If
Next
Next
you all were a great help with my last issue, so I figured Id ask another question. I am currently creating a code that keeps track of a mailroom's inventory. The code that I am working on is a textbox that whenever something is typed, it copies the value to the excel and it triggers an advanced search. I want to use xlfiltercopy to prevent visual damage to the excel sheet and so it is easier to update the listbox in the userform with the filtered information. Please let me know if you can find a reason that the error "AdvancedFilter method of Range class failed"
EDIT: If possible, I would like to email the entire excel to someone to see if the program works on another computer. I cannot physically think of a way to get it to work. Please consider it!
' Input on the 2nd page
' This code will update the list box below automatically as you type a name
Private Sub TextBox5_Change()
If Me.TextBox5.Value = "" Then
Exit Sub
End If
Dim wks As Worksheet
Set wks = ThisWorkbook.Sheets("Mail_Inventory")
Dim rgData As Range
Dim rgCriteria As Range
Dim rgOutput As Range
Dim currentinventory As Long
Dim filteredcurrent As Long
Dim temp As Long
temp = wks.Range("AS1").Value
If temp > 0 Then
wks.ListObjects("CurrentFiltered").DataBodyRange.Rows.Delete
End If
wks.Range("AP6").Value = Me.TextBox5.Value
currentinventory = wks.Range("A1").Value
'Set rgData = ThisWorkbook.Worksheets("Mail_Inventory").Range("A2:H" & currentinventory + 2)
'Set rgCriteria = ThisWorkbook.Worksheets("Mail_Inventory").Range("AP5:AP6")
'Set rgOutput = ThisWorkbook.Worksheets("Mail_Inventory").Range("AS2:AZ2")
Set rgData = Range("A2:H" & currentinventory + 2)
Set rgCriteria = Range("AP5:AP6")
Set rgOutput = Range("AS2:AZ2")
rgData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rgCriteria, CopytoRange:=rgOutput
'wks.Range("A2:H" & currentinventory + 2).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wks.Range("AP5:AP6"), CopyToRange:=wks.Range("AS2:AZ2")
'filteredcurrent = wks.Range("AS1").Value
'Me.ListBox2.Clear
'Me.ListBox2.RowSource = wks.Range("AS2:AV" & filteredcurrent + 2)
I have a Word file with approximately 10 pages and 20 tables. Some of these tables have checkboxes. I want to copy these tables into an Excel file.
The following code copies all tables from my Word file into my Excel file:
Sub Import()
Option Explicit
Dim wb As Workbook
Dim sh As Worksheet
Dim sheet As Worksheet
Dim lzeile As Integer
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set sheet = wb.Worksheets("Tabelle1")
Dim Btxt As Object
Set Btxt = CreateObject("Word.Application")
Btxt.Visible = True
Btxt.documents.Open "C:\Users\*.doc" '*=path
lzeile = 0
For i = 1 To 20
Btxt.ActiveDocument.Tables(i).Range.Copy
Application.Goto sheet.Cells(1 + lzeile, 1)
sheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
lzeile = sheet.Cells(Rows.Count, 1).End(xlUp).Row
lzeile = lzeile + 1
sheet.Cells(lzeile, 1) = "Tabelle" & i
Next i
Btxt.Quit
Set Btxt = Nothing
Set wb = Nothing
Set sh = Nothing
End Sub
It does not copy checkboxes or the value (0 = not checked / 1 = checked) of the checkbox.
I can write the value of a checkbox into a cell in my excel sheet with this line:
sheet.Cells(j, 10) = Btxt.ActiveDocument.Tables(i).FormFields.Item("Kontrollkästchen" & j).Result
With a loop j over all "Kontrollkästchen" (german translation of contentcontrol or formfield item) so basically the name of all formfield items in this Word file.
How can I get the position of these formfield items or identify which formfield item / ContentControl is in which table?
I tried to go through all rows and columns in each table because none of them are larger than 10x10. But I can´t find a way to check if a checkbox is maybe in table 3 on column 5 row 5 and then read the name of this checkbox to a safe the value (0 / 1) in the Excel cell on the same position in my copied table.
The solution depends on whether they're formfields or content controls.
Assuming they're formfields:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
j = Abs(.CheckBox.Value)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
Assuming they're content controls:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .ContentControls.Count To 1 Step -1
With .ContentControls(i)
If .Type = wdContentControlCheckBox Then
j = Abs(.Checked)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
For the sake of simplicity and clarity, the sample code below leaves out the parts having to do with Excel, as well as creating the instance of the Word Application. It shows only how to access the Word document's checkboxes and convert those to static values.
At the end, also, the document is closed without saving changes, which means forms protection and the checkboxes should be left intact - the macro will not have affected them.
Note: You should have Option Explicit at the top of the code page, not inside a "Sub".
How it works
The document to be processed is opened and at that moment set to an object (doc). Use this instead of ActiveDocument as it will be much clearer and, in case the user would try to do something, won't affect macro execution.
If the document has forms protection, this must be turned off in order to delete the checkboxes and insert static values.
Then all the form fields are looped. If they are checkboxes, the value is determined, the checkbox removed and the value assigned to the range the checkbox occupied.
After this has completed comes the code to transfer data to Excel. Then the document is closed without saving changes.
Sub ConvertCheckBoxesToValues()
Dim ff As Object ' Word.FormField
Dim doc As Object ' Word.Document
Dim cbValue As String
Dim rngFF As Object ' Word.Range
Set doc = Btxt.Documents.Open("C:\Users\*.doc") '*=path
If doc.ProtectionType <> -1 Then 'wdNoProtection
doc.Unprotect
End If
For Each ff In doc.FormFields
If ff.Type = 71 Then 'wdFieldFormCheckBox
If ff.CheckBox.value = True Then
cbValue = "1"
Else
cbValue = "0"
End If
Set rngFF = ff.Range
ff.Delete
rngFF = cbValue
End If
Next
'Transfer the information to Excel, then
doc.Close 0 'wdDoNotSaveChanges
End Sub
I would like to copy text from Excel to a Word file, add a page break in between (between line 50 and 51) and format the table in the Word file adjust the width of the table to the page of the Word document.
I have tried the InsertBreak and SetWidth methods but somehow produce errors (either syntax or object not defined).
Sub Button1()
Dim wd As Object
Worksheets("1").Activate
Range("C15:C73").Copy
Set wd = CreateObject("word.application")
wd.documents.Add
wd.Visible = True
wd.activedocument.Range.Pasteexceltable False, False, True
Worksheets("2").Activate
End Sub
The above is the code I currently use which works but does not have the page break after line 50 included neither is the table correctly formatted, i.e. column is to wide.
Is somebody maybe so kind to help / point me in the right direction?
Try this code and customize it to fit your needs:
Sub Button1()
' Define object variables
Dim wordObject As Object
Dim wordDocument As Object
Dim wordTable As Object
Dim rangeToCopy As Range
' Define other variables
Dim sheetName As String
Dim rangeAddress As String
Dim rowToInsertBreak As Integer
' >>>>>Customize
sheetName = "Sheet1" ' Sheet name in Excel
rangeAddress = "C15:C73" ' Range in Excel to copy from
rowToInsertBreak = 25 ' (index starts at 0 and first row is the header
' Initiate word object
Set wordObject = CreateObject("Word.Application")
' Add a new document
Set wordDocument = wordObject.Documents.Add
' Make the window visible
wordObject.Visible = True
' Define the range to copy
Set rangeToCopy = ThisWorkbook.Worksheets(sheetName).Range(rangeAddress)
' Copy the range
rangeToCopy.Copy
' Paste it into word
wordDocument.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
' Reference the table we just pasted
Set wordTable = wordDocument.Tables(1)
' Autofit the table
wordTable.AutoFitBehavior 2 ' wdAutoFitWindow: Check https://learn.microsoft.com/en-us/previous-versions/office/developer/office-2003/aa211923(v%3Doffice.11)
' Insert the page break after row
wordTable.Rows(rowToInsertBreak).Range.InsertBreak Type:=7 ' wdPageBreak
' Clear The Clipboard
Application.CutCopyMode = False
End Sub
Here are some links you'd check:
How to properly copy and paste excel tables into word:
https://www.thespreadsheetguru.com/blog/2014/5/22/copy-paste-an-excel-table-into-microsoft-word-with-vba
Note: It's often better to use word as a reference
How to deal with page breaks inside Word tables:
https://shaunakelly.com/word/styles/page-breaks-in-tables.html
I am trying to extract the source data from a PivotTable that uses a PivotTable cache and place it into a blank spreadsheet. I tried the following but it returns an application-defined or object defined error.
ThisWorkbook.Sheets.Add.Cells(1,1).CopyFromRecordset ThisWorkbook.PivotCaches(1).Recordset
Documentation indicates that PivotCache.Recordset is an ADO type, so this ought to work. I do have the ADO library enabled in references.
Any suggestions on how to achieve this?
Unfortunately, there appears to be no way to directly manipulate PivotCache in Excel.
I did find a work around. The following code extracts the the pivot cache for every pivot table found in a workbook, puts it into a new pivot table and creates only one pivot field (to ensure that all rows from the pivot cache are incorporated in the total), and then fires ShowDetail, which creates a new sheet with all of the pivot table's data in.
I would still like to find a way to work directly with PivotCache but this gets the job done.
Public Sub ExtractPivotTableData()
Dim objActiveBook As Workbook
Dim objSheet As Worksheet
Dim objPivotTable As PivotTable
Dim objTempSheet As Worksheet
Dim objTempPivot As PivotTable
If TypeName(Application.Selection) <> "Range" Then
Beep
Exit Sub
ElseIf WorksheetFunction.CountA(Cells) = 0 Then
Beep
Exit Sub
Else
Set objActiveBook = ActiveWorkbook
End If
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each objSheet In objActiveBook.Sheets
For Each objPivotTable In objSheet.PivotTables
With objActiveBook.Sheets.Add(, objSheet)
With objPivotTable.PivotCache.CreatePivotTable(.Range("A1"))
.AddDataField .PivotFields(1)
End With
.Range("B2").ShowDetail = True
objActiveBook.Sheets(.Index - 1).Name = "SOURCE DATA FOR SHEET " & objSheet.Index
objActiveBook.Sheets(.Index - 1).Tab.Color = 255
.Delete
End With
Next
Next
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Go to the Immediate Window and type
?thisworkbook.PivotCaches(1).QueryType
If you get something other than 7 (xlADORecordset), then the Recordset property does not apply to this type of PivotCache and will return that error.
If you get an error on that line, then your PivotCache is not based on external data at all.
If your source data comes from ThisWorkbook (i.e. Excel data), then you can use
?thisworkbook.PivotCaches(1).SourceData
To create a range object and loop through it.
If your QueryType is 1 (xlODBCQuery), then SourceData will contain the connection string and commandtext for you to create and ADO recordset, like this:
Sub DumpODBCPivotCache()
Dim pc As PivotCache
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set pc = ThisWorkbook.PivotCaches(1)
Set cn = New ADODB.Connection
cn.Open pc.SourceData(1)
Set rs = cn.Execute(pc.SourceData(2))
Sheet2.Range("a1").CopyFromRecordset rs
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub
You need the ADO reference, but you said you already have that set.
I found myself having the same problem, needing to scrape programmatically data coming different Excels with cached Pivot data.
Although the topic is a bit old, still looks there is no direct way to access the data.
Below you can find my code, which is a more generalized refinement of the already-posted solution.
The major difference is the filter removal from fields, as sometimes pivot comes with filters on, and if you call .Showdetail it will miss filtered data.
I use it to scrape from different file format without having to open them, it is serving me quite well thus far.
Hope it is useful.
Credit to spreadsheetguru.com on the filter cleaning routine (although I don't remember how much is original and how much is mine to be honest)
Option Explicit
Sub ExtractPivotData(wbFullName As String, Optional wbSheetName As_
String, Optional wbPivotName As String, Optional sOutputName As String, _
Optional sSheetOutputName As String)
' This routine extracts full data from an Excel workbook and saves it to an .xls file.
Dim iPivotSheetCount As Integer
Dim wbPIVOT As Workbook, wbNEW As Workbook, wsPIVOT As Worksheet
Dim wsh As Worksheet, piv As PivotTable, pf As PivotField
Dim sSaveTo As String
Application.DisplayAlerts = False
calcOFF
Set wbPIVOT = Workbooks.Open(wbFullName)
' loop through sheets
For Each wsh In wbPIVOT.Worksheets
' if it is the sheet we want, OR if no sheet specified (in which case loop through all)
If (wsh.name = wbSheetName) Or (wbSheetName = "") Then
For Each piv In wsh.PivotTables
' remove all filters and fields
PivotFieldHandle piv, True, True
' make sure there's at least one (numeric) data field
For Each pf In piv.PivotFields
If pf.DataType = xlNumber Then
piv.AddDataField pf
Exit For
End If
Next pf
' make sure grand totals are in
piv.ColumnGrand = True
piv.RowGrand = True
' get da data
piv.DataBodyRange.Cells(piv.DataBodyRange.Cells.count).ShowDetail = True
' rename data sheet
If sSheetOutputName = "" Then sSheetOutputName = "datadump"
wbPIVOT.Sheets(wsh.Index - 1).name = sSheetOutputName
' move it to new sheet
Set wbNEW = Workbooks.Add
wbPIVOT.Sheets(sSheetOutputName).Move Before:=wbNEW.Sheets(1)
' clean new file
wbNEW.Sheets("Sheet1").Delete
wbNEW.Sheets("Sheet2").Delete
wbNEW.Sheets("Sheet3").Delete
' save it
If sOutputName = "" Then sOutputName = wbFullName
sSaveTo = PathWithSlash(wbPIVOT.path) & FilenameNoExtension(sOutputName) & "_data_" & piv.name & ".xls"
wbNEW.SaveAs sSaveTo
wbNEW.Close
Set wbNEW = Nothing
Next piv
End If
Next wsh
wbPIVOT.Close False
Set wbPIVOT = Nothing
calcON
Application.DisplayAlerts = True
End Sub
Sub PivotFieldHandle(pTable As PivotTable, Optional filterClear As Boolean, Optional fieldRemove As Boolean, Optional field As String)
'PURPOSE: How to clear the Report Filter field
'SOURCE: www.TheSpreadsheetGuru.com
Dim pf As PivotField
Select Case field
Case ""
' no field specified - clear all!
For Each pf In pTable.PivotFields
Debug.Print pf.name
If fieldRemove Then pf.Orientation = xlHidden
If filterClear Then pf.ClearAllFilters
Next pf
Case Else
'Option 1: Clear Out Any Previous Filtering
Set pf = pTable.PivotFields(field)
pf.ClearAllFilters
' Option 2: Show All (remove filtering)
' pf.CurrentPage = "(All)"
End Select
End Sub