I made a specific Access Form that has many field with same names only the number at end changes. I have fields named "Code1", "Code2", "Code3" etc.
I would like to paste the fields from Form view to Excel Cells. There is about 150 fields and I don't want to add them one by one.
I made a button that opens Excel template, and made a For loop but I am stuck. This is the idea:
Set MyXL = CreateObject("Excel.Application")
With MyXL
.Application.Visible = True
.Workbooks.Open "F:\0. Main\01.Templates\Order.xltx"
Dim broj As Variant
broj = UCase(ID)
Dim Kod As Variant
Dim Tip As Variant
Dim Kolic As Variant
For i = 1 To 30
-------> Kod = Code(i).Value
.Worksheets("Sheet1").Cells(11 + i, 2).Value = Kod
-------> Tip = Type(i).Value
.Worksheets("Sheet1").Cells(11 + i, 3).Value = Tip
-------> Tip = Qty(i).Value
.Worksheets("Sheet1").Cells(11 + i, 3).Value = Kolic
Next i
I don't know how to include FieldName + (number) in For loop
Please check if a simple paste of the whole recordset directly to Excel's range will work (will overwrite starting at L2 as much as needed):
.Worksheets("Sheet1").Cells(12, 2).CopyFromRecordset
If this works, you may want to clear the range before pasting on it:
.Worksheets("Sheet1").Range("L2:N100000").ClearContent
If that doesn't help, you may want to loop over the recordset within Access e. g. like this:
Set rs = CurrentDb.OpenRecordset("WhatEver", dbOpenDynaset)
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst
i = 1
Do
... = rs.Fields("Code" & i).Value
...
rs.MoveNext
i = i + 1
Loop Until i > 30 ' or Until rs.EOF
End If
Option Compare Database
Sub Export()
Dim tableName As String
tableName = InputBox("What is the name of the table you want to export?")
Dim outputFileName As String
outputFileName = CurrentProject.Path & "\Export_" & Format(Date, "yyyyMMdd") & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, tableName, outputFileName, True
Set myXl = CreateObject("Excel.Application")
myXl.Visible = True
myXl.workbooks.Open outputFileName
End Sub
Related
I have written some code that plugs excel formulas exctracted from one file and stored in a db into a new excel file. Unfortunately those forumlas do not activate after being inserted and thus I receive an error when trying to import the value of those cells back into access. I tried to force calculation in excel using:
xlApp.Calculate
xlSheet.Calculate
xlApp.CalculateFull
xlApp.CalculateFullRebuild
which has no effect. It also does not work when using the button on the excel ribbon itself. I have also tried to set the cell format manually using:
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).NumberFormat = "0.0000"
Which has also not worked. The formula string inserts just fine into the excel file, it just doesnt activate and calculate the value of the cell. I can activate the cells by clicking on them and pressing enter etc. manually in the file but I want to do that in vba instead. Not sure where exactly the error is so I would appreciate any help. The code is quite long. The error occurs at
rsRes!Wert = xlSheet.Range("F" & i).Value
Here the full code:
Private Sub Befehl8_Click()
'Declare variables
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rsRes As DAO.recordset 'rs of temp table (Output)
Dim rsZwi As DAO.recordset 'rs of temp table (Zwischenwerte)
Dim rsRec As DAO.recordset 'rs clone of subform Rechenwerte
Dim rstRechenwerte As DAO.recordset
Dim rstZwischenwerte As DAO.recordset
Dim rstZutaten As DAO.recordset
Dim RezeptID As Integer
Dim RechengruppeID As Integer
Dim i As Integer
'Set Current Rezept and Rechengruppe
RezeptID = Me.RezeptID
RechengruppeID = Me.RechengruppeID
'Initialize variables
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Sheets("Tabelle1") 'Set xlSheet to the first sheet in the workbook
Set rsRes = CurrentDb.OpenRecordset("tblTempResults", dbOpenDynaset)
Set rsZwi = CurrentDb.OpenRecordset("tblTempZwischenwerte", dbOpenDynaset)
Set rsRec = Me.frmSubRechenwerteBox.Form.recordset.Clone
'Disable user input
Call mdlMiscFunctions.DisableKeyboardMouse(True)
'Clear temporary data tables for Results and Zwischenwerte
If Not rsRes.EOF Then Call ClearTableOnClose("tblTempResults")
If Not rsZwi.EOF Then Call ClearTableOnClose("tblTempZwischenwerte")
'Prevent prompt to save changes to excel
xlApp.DisplayAlerts = False
xlApp.Visible = True
' Open the Recordset for tblRechenwerte
Set rstRechenwerte = CurrentDb.OpenRecordset("SELECT Rechenwert, WertBezeichnung, XLCell FROM tblRechenwerte WHERE RechengruppeID = " & RechengruppeID)
' Insert the values of "Rechenwert" in the cells specified by "XLCell"
rstRechenwerte.MoveFirst
Do Until rstRechenwerte.EOF
xlSheet.Range(rstRechenwerte!XLCell).Value = rstRechenwerte!WertBezeichnung
xlSheet.Range(rstRechenwerte!XLCell).Offset(0, 1).Value = rstRechenwerte!Rechenwert
xlSheet.Range(rstRechenwerte!XLCell).Offset(0, 1).NumberFormat = "0.0000"
rstRechenwerte.MoveNext
Loop
xlApp.Calculate
xlSheet.Calculate
xlApp.CalculateFull
xlApp.CalculateFullRebuild
rstRechenwerte.Close
' Open the Recordset for tblZwischenwerte
Set rstZwischenwerte = CurrentDb.OpenRecordset("SELECT ZWBezeichnung, XLFormula, XLCell FROM tblZwischenwerte WHERE RezeptID = " & RezeptID)
' Insert the values of "ZWBezeichnung" in the cells specified by "XLCell"
rstZwischenwerte.MoveFirst
Do Until rstZwischenwerte.EOF
xlSheet.Range(rstZwischenwerte!XLCell).Value = rstZwischenwerte!ZWBezeichnung
xlSheet.Range(rstZwischenwerte!XLCell).Offset(0, 1).Formula = rstZwischenwerte!xlFormula
xlSheet.Range(rstZwischenwerte!XLCell).Offset(0, 1).NumberFormat = "0.0000"
rstZwischenwerte.MoveNext
Loop
xlApp.Calculate
xlSheet.Calculate
xlApp.CalculateFull
xlApp.CalculateFullRebuild
rstZwischenwerte.Close
' Open the Recordset for tblZutaten
Set rstZutaten = CurrentDb.OpenRecordset("SELECT Zutat, XLFormula, XLCell FROM tblZutaten WHERE RezeptID = " & RezeptID)
' Insert the values of "Zutat" in the cells specified by "XLCell"
rstZutaten.MoveFirst
Do Until rstZutaten.EOF
xlSheet.Range(rstZutaten!XLCell).Value = rstZutaten!Zutat
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).Formula = rstZutaten!xlFormula
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).NumberFormat = "0.0000"
rstZutaten.MoveNext
Loop
xlApp.Calculate
xlSheet.Calculate
xlApp.CalculateFull
xlApp.CalculateFullRebuild
rstZutaten.Close
'Extract data from excel and insert into tblTempResults
i = 4
Do Until IsEmpty(xlSheet.Range("E" & i).Value)
rsRes.AddNew
rsRes!RezepturKomponenten = xlSheet.Range("E" & i).Value
rsRes!Wert = xlSheet.Range("F" & i).Value
rsRes.Update
i = i + 1
Loop
'Extract data from exel and insert into tblTempZwischenwerte
i = 4
Do Until IsEmpty(xlSheet.Range("C" & i).Value)
rsZwi.AddNew
rsZwi!Zwischenwert = xlSheet.Range("C" & i).Value
rsZwi!Wert = xlSheet.Range("D" & i).Value
rsZwi.Update
i = i + 1
Loop
'Clean up and close excel
rsRes.Close
rsRec.Close
rsZwi.Close
xlWB.Close SaveChanges:=False
xlApp.Quit
'Release objects from memory
Set xlSheet = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
Set rsRes = Nothing
Set rsZwi = Nothing
Set rsRec = Nothing
Set rstRechenwerte = Nothing
Set rstRechenwerte = Nothing
Set rstZutaten = Nothing
'Refresh the main Form frmClacBatch
DoCmd.RunCommand acCmdRefresh
'Enable user input
Call mdlMiscFunctions.DisableKeyboardMouse(False)
End Sub
I still have to clean up the code so its still a work in progress, but most of it should work even if it could probably be simplified a bit.
Some info on the formats:
I am always opening a new excel workbook to insert the formulas so all cells are formatted as "standard" by default. I tried setting the format manually before AND after plugging in the formula like so:
rstZutaten.MoveFirst
Do Until rstZutaten.EOF
xlSheet.Range(rstZutaten!XLCell).Value = rstZutaten!Zutat
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).NumberFormat = "General"
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).Formula = rstZutaten!xlFormula
rstZutaten.MoveNext
Loop
I tried using "General" and some other formats like "0,000" etc. None have any effect.
The excel file itself after inserting the formulas looks something like this:
The formulas are correct and if I select the cell, click on the formula bar and hit enter, they calculate the value correctly and display that instead. Calculations are set to automatic as per default. I read that there might be issues if the formulas are not in english so I converted them to the english expression like =SUM(A3,B3:F12)instead of =SUMME(A3;B3:F12). That did not fix the issue either. The cells I plug the formulas into and the ones I try to extract the values from are correctly specified and are in fact the same cells.
I'm trying to import some data from tables in some word documents in excel using macros, but when it comes to open the word document and read it from an excel macro I can't do anything, because it says that I have no open document, but I do.
If I open a doc singularly calling it by its name it's alright, but the problem comes when I open files from a search and a loop.
Sub LoopFile()
Dim MyFile, MyPath As String
Dim wrdApp, wrdDoc
MyPath = "here goes my path with personal info, it points to a folder"
MyFile = Dir(MyPath)
Set wrdApp = CreateObject("Word.Application")
Do While MyFile <> ""
'parameters for the files to search
If MyFile Like "*.docx" And MyFile Like "All*" Then
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open(MyPath & MyFile)
Call GetID
wrdApp.Close
End If
MyFile = Dir
Loop
End Sub
Sub GetId()
Dim cicli, y As Integer
'counter for iterations
cicli = cicli + 1
'if it's first iteration it starts from column E, otherwise the next one
If (cicli = 1) Then
y = 5
Else
y = y + 1
End If
ActiveDocument.Tables(1).Cell(Row:=1, Column:=2).Range.Copy
ThisWorkbook.Worksheets("Foglio1").Cells(23, y).PasteSpecial xlPasteValues
End Sub
The problem comes when it arrives to
ActiveDocument.Tables(1).Cell(Row:=1, Column:=2).Range.Copy
How can I fix it?
Thank you
Pass the document you are referring to and avoid the ActiveDocument. E.g., try to fix it in a way like this:
Set wrdDoc = wrdApp.Documents.Open(MyPath & MyFile)
GetID wrdDoc
And then change a bit the GetId Sub, accepting the wrdDoc parameter.
Sub GetId(wrdDoc as Object)
Dim cicli, y As Integer
'counter for iterations
cicli = cicli + 1
If (cicli = 1) Then
y = 5
Else
y = y + 1
End If
wrdDoc.Tables(1).Cell(Row:=1, Column:=2).Range.Copy
ThisWorkbook.Worksheets("Foglio1").Cells(23, y).PasteSpecial xlPasteValues
End Sub
How to avoid using Select in Excel VBA
I'm trying to workout how to split the unique records of a query to new worksheets in the same excel workbook (template file). My access query has the following fields:
Project Number,Project Name,Task Number,Project Sponsor,Full Year Budget,APR,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec,Jan,Feb,Mar,Full,Year Forecast.
I want to be able to have a new worksheet for each Project Number and list the relevant data, and also rename the worksheet as the Project Number...I have a complete mind block after spending hours playing around with other code for similar requests, but cannot get anything to behave the way I need it to?
Does any one have a ideas or could point me in the right direction, I'm not a complete novice at vba but this one has me well and truly stuck.
Many thanks :)
Hi All, thanks for the suggestions, I've managed to cobble together the code to spilt the data and export to individual worksheets and its working ok.I now need to copy over any associated data from another query to the relevant worksheet in a "table" below the other data, but I'm not having much luck. Either it will copy one record to one of the worksheets or all of the records to a single worksheet irrespective. Can anyone point me in the right direction?
Option Compare Database
Global iter As Integer
Sub Loop_Practice2()
Dim rs As DAO.Recordset
Dim ProjectNumber As DAO.Recordset
Dim i As Integer
Dim j As Integer
Dim Worksheet_Count As Integer
Dim sSql As String
Dim Project_Count As Integer
Dim iCol As Integer
Dim mypath As String
Dim mvalue As String
Dim myfile As String
Dim mynewfile As String
Dim mynewpath As String
Dim wb As Excel.Workbook
Dim WS As Excel.Worksheet
Dim sFile As String
mypath = Application.CurrentProject.Path & "\"
myfile = ("PIN Export Template.xlsx")
mynewpath = (Application.CurrentProject.Path & "\")
mynewfile = ("PIN Export Template.xlsx - " & Format(Now(), "yyyy-mm-dd") & ".xlsx")
sFile = mypath & myfile
' ' Use Dir to check if file exists
If Dir(sFile) = "" Then
' if file does not exist display message
MsgBox "Could not find the file " & sFile & " - Please ensure it is in the same location as the database."
Exit Sub
End If
'Open Excel
Excel.Application.Visible = True
Excel.Application.Workbooks.Open (sFile)
'Define Access Query to be exported
Set ProjectNumber = CurrentDb.OpenRecordset("SELECT DISTINCT qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly.[Project Number] from qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly")
If ProjectNumber.EOF Then Exit Sub
ProjectNumber.MoveLast
Project_Count = ProjectNumber.RecordCount - 1
ProjectNumber.MoveFirst
'Create individual PIN sheets from Query Dataset
Excel.Application.Worksheets("PIN").Select
Worksheet_Count = Excel.Application.Worksheets("PIN").Select
Do Until Worksheet_Count = Project_Count
Worksheets("PIN").Copy After:=Worksheets("PIN")
If iter = 0 Then
iter = 1
End If
ActiveSheet.Name = ("PIN") & iter
iter = iter + 1
Worksheet_Count = Worksheet_Count + 1
Loop
j = 1
'Add qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly data
Do Until ProjectNumber.EOF
sSql = "SELECT *"
sSql = sSql & " FROM qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly"
sSql = sSql & " Where qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly.[Project Number]=" & ProjectNumber("[Project Number]")
Set rs = CurrentDb.OpenRecordset(sSql, dbOpenDynaset)
Set Pin_Sheet = ActiveWorkbook.Sheets("PIN" & j)
'Rename the PIN sheet to individual Project Number
Pin_Sheet.Name = ProjectNumber("[Project Number]")
'Create PIN Analysis Column Headings
For iCol = 0 To rs.Fields.Count - 1
Pin_Sheet.Cells(13, iCol + 4).Value = rs.Fields(iCol).Name
Next
'Populate PIN_Analysis_Step_01_FY_Position_Monthly Data
Pin_Sheet.Cells(14, 4).CopyFromRecordset rs
j = j + 1
ProjectNumber.MoveNext
Loop
Excel.Application.ActiveWorkbook.SaveAs (mynewpath & mynewfile)
Set Pin_Sheet = Nothing
Set ProjectNumber = Nothing
Set ProjectNumber2 = Nothing
Set rs = Nothing
Set ProjectNumber = Nothing
Set wb = Nothing
Set WS = Nothing
CurrentDb.Close
ActiveWorkbook.Close
Excel.Application.Quit
End Sub
AS 'Erik von Asmuth' Suggested it is a broad question split into a different task and share your code. what you have attempted until now.
I can only point you to one article written by Daniel Pineault . He had created a function called ExportRecordset2XLS through which you can pass your recordset, Sheet Name etc.
you have to create a loop for different project number and pass as an argument to this function. you also need to modify this code to handle differnt task as per your requiremnts.
https://www.devhut.net/2017/03/15/ms-access-vba-export-recordset-to-excel/
I've Searched Forums here and I can't seem to get this code to work.
I am Trying to Open a Workbook in Excel, and then populate a few of the Cells(Named Ranges). I can successfully open the workbook(the workbook has a bit of VBA that runs when it opens as well, formatting stuff only) but when I get down to the inputting information I get a 'Run-Time Error "438" Object Doesn't support this property or method.'
From the Previous answers on other similar questions I have done everything the way it was suggested however, I can't seem to get it to work.
Option Compare Database
Option Explicit
Public Sub MaterialInput()
Dim xlapp As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim RsClient As Recordset
Dim RsJobsite As Recordset
Dim db As Database
Dim ClientSTR As String
Dim JobsiteSTR As String
Dim customer As Variant
Set db = CurrentDb
JobsiteSTR = "SELECT T1Jobsites.JobsiteNickName FROM T1Jobsites WHERE T1Jobsites.JobsiteID = 1" ' & Form_LEM.TxtJobsiteID
Set RsJobsite = db.OpenRecordset(JobsiteSTR, dbOpenSnapshot, dbSeeChanges)
ClientSTR = "SELECT T1Companies.CompanyName " & _
"FROM T1Companies INNER JOIN T1Jobsites ON T1Companies.CompanyID = T1Jobsites.CompanyId " & _
"WHERE (((T1Jobsites.JobsiteID)=1))"
'ClientSTR = "SELECT T1Companies.CompanyName FROM T1Companies INNER JOIN T1Jobsites ON T1Companies.CompanyID = T1Jobsites.CompanyID" & _
" WHERE T1JobsitesID = 1" '& Form_LEM.TxtJobsiteID
Set RsClient = db.OpenRecordset(ClientSTR, dbOpenSnapshot, dbSeeChanges)
Set xlapp = CreateObject("excel.application")
Set wb = xlapp.Workbooks.Open("C:\Users\coc33713\Desktop\VISION - EXCEL FILES\VISIONCOUNT.xlsm")
Set ws = xlapp.Worksheets("CountSheet")
xlapp.Visible = True
'Tried this second after reading another forum
'the comments Recordset will be the actual values used, but I can't get the String "TEST" to work
wb.ws.Range("Client").Value = "TEST" 'RsClient!CompanyName
'Tried this way first
xlapp.ws.Range("'SiteName'").Value = "Test" 'RsJobsite!JobsiteNickName"
xlapp.ws.Range(Date).Value = "Test" 'Form_LEM.TxtDate
xlapp.ws.Range(ProjectName).Value = "Test" 'Form_LEM.TxtPlant
xlapp.ws.Range(ScaffoldID).Value = "Test" 'Form_LEM.cboScaffnum.Value
xlapp.ws.Range(ScaffoldNumber).Value = "Test" 'Form_LEM.cboScaffnum.Column(1)
Set xlapp = Nothing
Set wb = Nothing
Set ws = Nothing
Set RsClient = Nothing
Set RsJobsite = Nothing
Set db = Nothing
End Sub
As a Sidenote this is not a form it is just spreadsheet
Thank you everyone!
Use
ws.Range("Client").Value = "Test"
Or
Dim sName as String
sName = "Client"
ws.Range(sName).Value = "Test"
Reason being is that you have the ws object set already, so there is no need to assign parentage to it again. In fact, trying to do so will break syntax rules.
FWIW (not your issue - that is solved by Scott's answer): Note that
Set ws = xlapp.Worksheets("CountSheet")
should be
Set ws = wb.Worksheets("CountSheet").
Using xlapp.Worksheets("CountSheet")
is effectively xlApp.ActiveWorkbook.Worksheets("CountSheet") which might be (and probably is) xlApp.Workbooks("VISION - EXCEL FILES\VISIONCOUNT.xlsm").Worksheets("CountSheet") but it is better to do it correctly rather than leave it to chance.
Thank you guys!
This should do what you want.
Sub DAOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim db As Database, rs As Recordset, r As Long
Set db = OpenDatabase("C:\FolderName\DataBaseName.mdb")
' open the database
Set rs = db.OpenRecordset("TableName", dbOpenTable)
' get all records in a table
r = 3 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("FieldName1") = Range("NamedRange1").Value
.Fields("FieldName2") = Range("NamedRange2").Value
.Fields("FieldNameN") = Range("NamedRangeN").Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
I have an Excel chart. One of the series has X and Y error bars, defined from worksheet ranges.
I want to get via VBA those ranges (not set them). Is this possible?
Jon Peltier has an article about error bars on his blog here
Quoting from that:
Programmatically Defining Custom Error Bars
The command to add error bars using Excel is: {Series}.ErrorBar
Direction:={xlX or xlY}, Include:=xlBoth, Type:=xlCustom, _
Amount:={positive values}, MinusValues:={negative values} Values can be a single numerical value, for example, 1, an comma-separated
array of numerical values in curly braces, such as {1,2,3,4}, or a
range address in R1C1 notation. For values in Sheet1!$G$2:$G$10, enter
the address as Sheet1!R2C7:R10C7. Combine both plus and minus in the
same command. In Excel 2007, if you don’t want to show a particular
error bar, you must enter a value of zero in this command. In 2003,
you can enter a null string “”. In Excel 2003, the range address must
begin with an equals sign, =Sheet1!R2C7:R10C7; Excel 2007 accepts the
address with or without the equals sign. Single values or arrays may
be entered with or without the equals sign in either version of Excel.
In a post on Ozgrid, Jon Peltier says
the range for custom error bar values is not exposed to VBA
If Jon says it can't be done, it can't be done.
I know I'm 8 years late to the party here... but I stumbled upon this while scouring the web for the answer to this same question. I came up empty too, so I decided to devise my own solution, and figured I might as well post it on the off chance that someone else ends up here.
It works by extracting the workbook XML to a temporary folder, locating the error bar reference in the XML, and returning it as a Range object. You therefore have to save changes to the workbook before the function will work. If you change the error bar range without saving, the function will still return the old range from the most recent save. It also will not work on files from Excel 2003 or earlier (.xls).
It's anything but elegant... but at least this is technically possible!
To use: just copy the code below into a standard module, and call GetErrorBarRange(MySeries.ErrorBars, enErrorBarPlus) for the source range of the positive error bar, or GetErrorBarRange(MySeries.ErrorBars, enErrorBarMinus) for the source range of the negative error bar (where MySeries.ErrorBars is some ErrorBars object). Passing the optional third argument AutoSave:=True will save the containing workbook automatically before looking for the error bar source ranges.
' Created by Ryan T. Miller in 2022
' You may use this code in your own work however you wish. It'd be real swell of you
' to leave this credit in if you do, but I'm not gonna force you to.
Option Explicit
Option Private Module
Public Enum EnErrorBarPlusMinus
enErrorBarPlus
enErrorBarMinus
End Enum
Private moFSO As Object
' Get error bar source range from ErrorBars object
Public Function GetErrorBarRange(oErrorBars As ErrorBars, _
PlusMinus As EnErrorBarPlusMinus, _
Optional AutoSave As Boolean) As Range
Dim oFile As Object
Dim strTempDir As String
Dim strSubfolder As String
Dim oSeries As Series
Dim oChart As Chart
Dim oSheet As Object
Dim oWb As Workbook
Dim strPrefix As String
Dim strSeriesName As String
Dim strChartName As String
Dim strSheetName As String
Dim strXMLFile As String
Dim strXPath As String
Dim strCurrentSheet As String
Dim strRelId As String
Dim strDrawingXml As String
Dim strChartXml As String
Dim strErrValType As String
Dim strErrBarType As String
Dim strErrBarFormula As String
Dim rngResult As Range
On Error GoTo CleanUp
If Not (PlusMinus = enErrorBarMinus _
Or PlusMinus = enErrorBarPlus) Then Exit Function
Set moFSO = CreateObject("Scripting.FileSystemObject")
Application.Cursor = xlWait
' Set Series, Chart, Sheet, and Workbook objects
Set oSeries = oErrorBars.Parent
Set oChart = oSeries.Parent.Parent
If TypeOf oChart.Parent Is ChartObject Then
' Chart is on a worksheet
Set oSheet = oChart.Parent.Parent
strPrefix = "work"
Else
' Chart is on its own chart sheet
Set oSheet = oChart
strPrefix = "chart"
End If
Set oWb = oSheet.Parent
If AutoSave Then oWb.Save
' Name of the series, chart & its parent sheet
strSeriesName = oSeries.Name
strChartName = oChart.Parent.Name
strSheetName = oSheet.CodeName
strTempDir = ExtractWorkbookXMLToTemp(oWb)
' Loop over worksheet/chartsheet XML files & find the one where /worksheet/sheetPr/#codeName=strSheetName
' Then get strRelId from /worksheet/drawing/#r:id
' This is the ID which specifies which relationship links the sheet to the drawings.
strSubfolder = moFSO.BuildPath(strTempDir, "xl\" & strPrefix & "sheets")
strXPath = "/x:" & strPrefix & "sheet/x:sheetPr/#codeName"
For Each oFile In moFSO.GetFolder(strSubfolder).Files
strXMLFile = moFSO.BuildPath(strSubfolder, oFile.Name)
strCurrentSheet = GetXPathFromXMLFile(strXMLFile, strXPath)
If strSheetName = strCurrentSheet Then Exit For
Next oFile
strXPath = "/x:" & strPrefix & "sheet/x:drawing/#r:id"
strRelId = GetXPathFromXMLFile(strXMLFile, strXPath)
' Open the _rels XML associated with the correct sheet.
' Then get strDrawingXml from /Relationships/Relationship[#Id='strRelId']/#Target
' This is the name of the drawing XML.
strSubfolder = strSubfolder & "\_rels"
strXMLFile = moFSO.BuildPath(strSubfolder, moFSO.GetFileName(strXMLFile)) & ".rels"
strXPath = "/rel:Relationships/rel:Relationship[#Id='" & strRelId & "']/#Target"
strDrawingXml = GetXPathFromXMLFile(strXMLFile, strXPath)
strDrawingXml = Replace$(Replace$(strDrawingXml, "../", "/"), "/", "\")
' Open the correct drawing XML file (strDrawingXml)
' Then get strRelId from xdr:wsDr//xdr:graphicFrame[xdr:nvGraphicFramePr/xdr:cNvPr/#name='strChartName']/a:graphic/a:graphicData/c:chart/#r:id
' Or, if oSheet is a ChartSheet, there will only be 1 chart, so just get xdr:wsDr//xdr:graphicFrame/a:graphicData/a:graphic/c:chart/#r:id
' This is the ID which specifies which relationship links the drawing to the chart.
strXMLFile = moFSO.BuildPath(strTempDir, "xl" & strDrawingXml)
strXPath = "xdr:wsDr//xdr:graphicFrame" & _
IIf(TypeOf oChart.Parent Is ChartObject, "[xdr:nvGraphicFramePr/xdr:cNvPr/#name='" & strChartName & "']", vbNullString) & _
"/a:graphic/a:graphicData/c:chart/#r:id"
strRelId = GetXPathFromXMLFile(strXMLFile, strXPath)
' Open the _rels associated with the correct drawing XML.
' Then get strChartXml = /Relationships/Relationship[#Id='strRelId']/#Target
' This is the name of the chart XML.
strSubfolder = moFSO.GetParentFolderName(strXMLFile) & "\_rels"
strXMLFile = moFSO.BuildPath(strSubfolder, moFSO.GetFileName(strXMLFile)) & ".rels"
strXPath = "/rel:Relationships/rel:Relationship[#Id='" & strRelId & "']/#Target"
strChartXml = GetXPathFromXMLFile(strXMLFile, strXPath)
strChartXml = Replace$(Replace$(strChartXml, "../", "/"), "/", "\")
' Open the correct chart XML file (strChartXml)
strXMLFile = moFSO.BuildPath(strTempDir, "xl" & strChartXml)
' Get error bar value type. If the error bar is set to a Range then this must be 'cust'.
strXPath = "/c:chartSpace/c:chart//c:ser[c:tx//c:v[text()='" & strSeriesName & "']]/c:errBars/c:errValType/#val"
strErrValType = GetXPathFromXMLFile(strXMLFile, strXPath)
' Get error bar type. This can be "minus", "plus", or "both" depending on which error bar(s) exist(s).
strXPath = "/c:chartSpace/c:chart//c:ser[c:tx//c:v[text()='" & strSeriesName & "']]/c:errBars/c:errBarType/#val"
strErrBarType = GetXPathFromXMLFile(strXMLFile, strXPath)
' Get the Range address for either the "minus" or "plus" error bar and set it to the final result.
If strErrValType = "cust" Then
strXPath = "/c:chartSpace/c:chart//c:ser[c:tx//c:v[text()='" & strSeriesName & "']]/c:errBars"
If PlusMinus = enErrorBarMinus And (strErrBarType = "both" Or strErrBarType = "minus") Then
strXPath = strXPath & "/c:minus/c:numRef/c:f"
ElseIf PlusMinus = enErrorBarPlus And (strErrBarType = "both" Or strErrBarType = "plus") Then
strXPath = strXPath & "/c:plus/c:numRef/c:f"
EndIf
strErrBarFormula = GetXPathFromXMLFile(strXMLFile, strXPath)
strErrBarFormula = "'[" & oWb.Name & "]" & Replace$(strErrBarFormula, "!", "'!")
Set rngResult = Application.Range(strErrBarFormula)
End If
Set GetErrorBarRange = rngResult
CleanUp:
' Delete the temporary extracted XML data
With moFSO
If .FolderExists(strTempDir) Then .DeleteFolder strTempDir
End With
Set moFSO = Nothing
' Free the cursor
Application.Cursor = xlDefault
End Function
' Get the value of an XML node by an XPath search string
Private Function GetXPathFromXMLFile(ByVal strXMLFile As String, ByVal strXPath As String) As String
Dim objXMLDoc As Object
Dim strNS As String
Dim objXMLNode As Object
' Load the XML file
Set objXMLDoc = CreateObject("MSXML2.DOMDocument.6.0")
objXMLDoc.Load strXMLFile
' These are all the XML namespaces related to the current task
strNS = Join$(Array( _
"xmlns:x=""http://schemas.openxmlformats.org/spreadsheetml/2006/main""", _
"xmlns:r=""http://schemas.openxmlformats.org/officeDocument/2006/relationships""", _
"xmlns:mc=""http://schemas.openxmlformats.org/markup-compatibility/2006""", _
"xmlns:x14ac=""http://schemas.microsoft.com/office/spreadsheetml/2009/9/ac""", _
"xmlns:xr=""http://schemas.microsoft.com/office/spreadsheetml/2014/revision""", _
"xmlns:xr2=""http://schemas.microsoft.com/office/spreadsheetml/2015/revision2""", _
"xmlns:xr3=""http://schemas.microsoft.com/office/spreadsheetml/2016/revision3""", _
"xmlns:rel=""http://schemas.openxmlformats.org/package/2006/relationships""", _
"xmlns:xdr=""http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing""", _
"xmlns:a=""http://schemas.openxmlformats.org/drawingml/2006/main""", _
"xmlns:c=""http://schemas.openxmlformats.org/drawingml/2006/chart""", _
"xmlns:c16r2=""http://schemas.microsoft.com/office/drawing/2015/06/chart""" _
))
objXMLDoc.SetProperty "SelectionLanguage", "XPath"
objXMLDoc.SetProperty "SelectionNamespaces", strNS
objXMLDoc.resolveExternals = True
' Select the XML node and return its text value
Set objXMLNode = objXMLDoc.SelectSingleNode(strXPath)
If Not objXMLNode Is Nothing Then
GetXPathFromXMLFile = objXMLNode.Text
End If
End Function
' If workbook path is a OneDrive URL or a network share URL then resolve it to a local path with a drive letter
Private Function LocalFilePath(ByVal strFilePath As String)
strFilePath = OneDriveLocalFilePath(strFilePath)
strFilePath = NetworkLocalFilePath(strFilePath)
LocalFilePath = strFilePath
End Function
' If workbook path is a OneDrive URL then resolve it to a local path with a drive letter
Private Function OneDriveLocalFilePath(ByVal strFilePath As String) As String
Dim strOneDrivePath As String
Dim strLocalPath As String
If strFilePath Like "*my.sharepoint.com*" Then
strOneDrivePath = Environ$("OneDriveCommercial")
If strOneDrivePath = vbNullString Then strOneDrivePath = Environ$("OneDrive")
strLocalPath = strOneDrivePath & "/" & Split(strFilePath, "/", 7)(6)
OneDriveLocalFilePath = Replace$(strLocalPath, "/", "\")
ElseIf strFilePath Like "*d.docs.live.net*" Then
strOneDrivePath = Environ$("OneDriveConsumer")
If strOneDrivePath = vbNullString Then strOneDrivePath = Environ$("OneDrive")
strLocalPath = strOneDrivePath & "/" & Split(strFilePath, "/", 5)(4)
OneDriveLocalFilePath = Replace$(strLocalPath, "/", "\")
Else
OneDriveLocalFilePath = strFilePath
End If
End Function
' If workbook path is a network share URL then resolve it to a local path with a drive letter
Private Function NetworkLocalFilePath(ByVal strFilename As String) As String
On Error Resume Next
Dim ShellScript As Object
Dim i As Long
Dim strDriveLetter As String * 1
Dim strRemotePath As String
Set ShellScript = CreateObject("WScript.Shell")
For i = 97 To 122 ' a to z
strDriveLetter = Chr$(i)
strRemotePath = ShellScript.RegRead("HKEY_CURRENT_USER\Network\" & strDriveLetter & "\RemotePath")
If Err.Number = 0 Then
If strFilename Like strRemotePath & "*" Then
NetworkLocalFilePath = Replace$(strFilename, strRemotePath, UCase$(strDriveLetter) & ":", Count:=1)
Exit Function
End If
Else
Err.Clear
End If
Next i
NetworkLocalFilePath = strFilename
End Function
' Extract workbook XML to temporary directory
Private Function ExtractWorkbookXMLToTemp(oWb As Workbook) As String
Dim strTempDir As String
Dim strExt As String
Dim strTempWb As String
Dim strWbLocal As String
Dim strZipFile As String
On Error GoTo CleanUp
' Create a temporary copy of the workbook
With moFSO
strTempDir = .BuildPath(Environ$("TEMP"), _
Replace$(.GetTempName, ".tmp", vbNullString))
strExt = .GetExtensionName(oWb.Name)
strTempWb = strTempDir & "." & strExt
strWbLocal = LocalFilePath(oWb.FullName)
.CopyFile strWbLocal, strTempWb
End With
' Rename the temporary copy from .xls_ to .zip
strZipFile = strTempDir & ".zip"
Name strTempWb As strZipFile
' Unzip the .zip file to a temporary folder
MkDir strTempDir
UnzipFiles strZipFile, strTempDir
' Return the name of the temporary directory
ExtractWorkbookXMLToTemp = strTempDir
CleanUp:
' Delete the temporary ZIP file
With moFSO
If .FileExists(strZipFile) Then .DeleteFile strZipFile
End With
End Function
' Unzip all the files in 'varZipFile' into the folder 'varDestDir'
Private Sub UnzipFiles(ByVal varZipFile As Variant, ByVal varDestDir As Variant)
Dim oShellApp As Object
Const NO_PROGRESS_DIALOG As Integer = &H4
Set oShellApp = CreateObject("Shell.Application")
If Not varDestDir Like "*\" Then varDestDir = varDestDir & "\"
With oShellApp
.Namespace(varDestDir).CopyHere .Namespace(varZipFile).Items, NO_PROGRESS_DIALOG
End With
On Error Resume Next
With oShellApp
Do Until .Namespace(varZipFile).Items.Count = .Namespace(varDestDir).Items.Count
Application.Wait Date + (VBA.Timer + 1!) / 86400
Loop
End With
On Error GoTo 0
End Sub