Numeric Values Change During Access VBA DoCmd.TransferSpreadsheet - excel

I'm developing a module to automatically import Excel worksheets into an Access table. The design of the worksheets being imported are identical. Using DoCmd.TransferSpreadsheets imports columns A-O (a mix of text and numeric data) well, however the values for columns P-AD have issues...
Column P and Q represent beginning and ending odometer values with R their elapsed distance. For example, on the worksheet Vehicle OHS-11 is reported as beginning at 154952, ending at 155636, for an elapsed distance of 684. The imported record shows as beginning AND ending at 155636, for an elapsed distance of 0.
Columns S-AA just refuse to import at all. Column AB imports 0 for all records including those with legitimate values (i.e., not null). Columns AC-AD sporadically import a 0, but many records are blank. See the figure below:
I've tried to no avail:
setting the field types in Access
letting Access create the table from scratch
DoCmd.RunSavedImport isn't ideal since the source spreadsheets have different names
a SELECT * INTO will create a new table for each worksheet and I am needing to consolidate the data from all spreadsheets to a single table
It is peculiar that the imports are successful without transfer error tables being created but yet the values are being ignored/swapped. Should it matter, the cells in columns E-P, R and AB-AD are formulas.
I am using Excel 2016 and Access 2016 on a Windows 10 tablet system. Here is the code:
Option Compare Database
Sub Import_New_WS()
'--- Import new worksheets to temporary table
Dim dbAC As Database
Dim rsList, rsMonth, rsXfer As Recordset
Dim strDestPath, strFilePath, strMFRSheetNo, strRange As String
Set dbAC = CurrentDb()
Set rsList = dbAC.OpenRecordset("SELECT * FROM [XFER_LIST_ONLY_LATEST_MFR]")
Set rsMonth = dbAC.OpenRecordset("SELECT * FROM [FP_MO_CAL_MO]")
'Set rsXfer = dbAC.OpenRecordset("SELECT * FROM [XFER_WS]")
If rsList.EOF = True Then Exit Sub 'Checks that there are worksheets to process
'--- Delete existing records from MFR consolidation table
'DoCmd.SetWarnings False
'DoCmd.RunSQL "DELETE * FROM [XFER_WS];"
'DoCmd.SetWarnings True
'--- Import worksheets into consolidation table
rsList.MoveFirst
strMFRSheetNo = Right(CStr(rsList.Fields("MFR_LAST_FP")), 2)
Do Until rsList.EOF
rsMonth.FindFirst "FISCAL_MO = " & strMFRSheetNo
strRange = rsMonth.Fields("WS_NAME") & "!A2:AD" & Format(rsList.Fields("NO_ROWS") + 1, "0")
strFilePath = rsList.Fields("FILE_PATH")
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "XFER_WS", strFilePath, False, strRange
strDestPath = "I:\Dept\DCS\MPOOL\Fleet Management Data\MFR\MFR FY " & Mid(CStr(rsList.Fields("MFR_LAST_FP")), 3, 2) & _
"\" & Mid(strFilePath, 81, Len(strFilePath))
Debug.Print strDestPath
'FileCopy strFilePath, strDestPath
'Kill strFilePath
rsList.MoveNext
Loop
Set dbAC = Nothing
Set rsList = Nothing
Set rsXfer = Nothing
Set rsMonth = Nothing
DeleteImportErrorTables
End Sub

After much research and testing multiple strategies to address this issue I simply went back to my original code and somehow it spontaneously started working correctly. The following day however, it was back to the original anomalous behavior!
Unable to find a solution to the issue I coded around the problem by saving the worksheet as a comma separated value (.csv) file and using DoCmd.TransferText instead. This strategy circumvented Access' data type guesswork and quickly imported the data into the table. (As an aside, DoCmd.TransferText doesn't like filenames with more than a single period in them.)

Related

Error 1004 - item could not be found in OLAP cube after file copied/name changed

I have a workbook which connects to data models through PowerPivot, and the resulting pivot tables are filtered based on a given array collected through a difference process.
Sub AccrualPivot()
'Filter the data for the accrual entries that have been made.
Dim myArray() As Variant
Dim myR As Range
Sheets("Tables").Activate
Sheets("Tables").Range("JournalNum1").Select
Set myR = Sheets("Tables").Range("JournalNum1")
ReDim myArray(0 To myR.Cells.Count - 1)
Sheets("Data").Select
ActiveSheet.PivotTables("AccrualPivot").PivotFields( _
"[Query].[DataEntry].[DataEntry]").ClearAllFilters
ActiveSheet.PivotTables("AccrualPivot").PivotFields( _
"[Query].[JournalNum].[JournalNum]").ClearAllFilters
For i = 0 To myR.Cells.Count - 1
myArray(i) = "[Query].[JournalNum].&[" & myR.Cells(i + 1).Value & "]"
Next i
'ERROR THROWS HERE
ActiveSheet.PivotTables("AccrualPivot").PivotFields( _
"[Query].[JournalNum].[JournalNum]").VisibleItemsList = myArray
'This filters out the Data entries, which need to be included in a separate pivot.
ActiveSheet.PivotTables("AccrualPivot").PivotFields( _
"[Query].[DataEntry].[DataEntry]").CurrentPageName = _
"[Query].[DataEntry].&[0]"
End Sub
The error on the indicated line:
Run-time error '1004': The item could not be found in the OLAP cube.
When I put a watch on this line, both expressions are Variants and myArray has populated with the necessary information. The kicker (and I'm assuming the root) is that this works in my original file. But I need to be able to Save As the workbook to roll over for each month.
I need a file for 4.30, 5.31, etc. If I save the workbook as the following month, change the dates and run everything, it works. But if I close that file, reopen and try to run, I get the 1004 error.
Nowhere in the module do I reference the file name or file path. They're even saved in the same path, just as separate months, and all the sheets are named the same. I'm assuming it's embedded somewhere that I can't find.
I had the same problem, but fiddling with the variable UpdateStr made it work.
There is probably a cleaner way of doing this, but... it worked for me!
Sub FormatTables()
Dim i As Integer
Dim UpdateStr As String
Dim MySheet As Worksheet
Dim pt As PivotTable
Dim pf As PivotField
On Error Resume Next
For i = 1 To ActiveWorkbook.Worksheets.Count
Set MySheet = ActiveWorkbook.Worksheets(i)
If Left(MySheet.name, 7) = "looking for specific sheet names to modify the pivots" Then
For Each pt In MySheet.PivotTables
For Each pf In pt.PivotFields
' I am looping through all fields as I'm doing multiple pivot filtering, and setting different fields to other values... but in this example I only include one field.
If pf.Caption = "CoverageYear" Then
With pf
.ClearAllFilters
UpdateStr = Left(pf.Value, InStrRev(pf.Value, ".")) & "&[2019]"
.CurrentPageName = UpdateStr
End With
End If
Next
pt.RefreshTable
Next
End If
Next i
End Sub
I recently had this error and found Delora Bradish helpful: Rebuild the data model and run the code again.
The powerquery data model is fragile and there are unpredictable consequences when a table is renamed. Also, if you are scripting the model build, the order in which tables are added matters; though tables can be added simultaneously (multi-core processing), and it usually works just fine, sometimes the resulting model misses a table reference somewhere and you get this error. Change the load order to ensure good separation of the big files.
If you are using powerquery, you should have a plan for clean rebuilds of your data model from time to time.

Generate workbook unique ID from template in Excel

In my organization we have an Excel template that all employees have to fill frequently. This template originates hundreds/thousands of Excel files (workbooks) per year.
For the sake of organisation, I urgently need to have a unique ID for each of these files (i.e. unique ID per workbook generated by this template).
Currently, my idea is to generate the following ID in a cell of the workbook:
[user]-[YYYYMMDD]-[hhmmss]
in which:
user is a string representing the username of the employee which would be filled in by the user. So no problem here.
YYYYMMDD is year, month and day
concatenated
hhmmss is hour, minute and second concatenated
For this effect, I would need that my Excel template automatically fills a cell with the YYYYMMDD-hhmmss information with the exact date and time of generation.
This information should be created once the template generates the workbook, and cannot be changed ever after. So these should be values in a (protected) cell and not a formula (I guess).
I cannot figure out how to do this after searching for a long time. I am not sure if it is needed or not, but I am no master of VBA.
The idea of having a date/time field is good .... create a workbook smilar to this
add the following code to the ThisWorkbook module:
Private Sub Workbook_Open()
If [B2] = "" Then
' timestamp
[B2] = Now()
' suppress warning when saving macro containing workbook in non-macro format
Application.DisplayAlerts = False
' save under calculated name
ActiveWorkbook.SaveAs [B1] & "-" & Format([B2], "YYYYMMDD-hhmmss")
' turn on alerts again
Application.DisplayAlerts = True
End If
End Sub
and save as a macro enabled template
Then create a [File - New] from this template .... it will immediately be saved under the name of the user with macros removed so that the code can't hit it another time.
The user name could be retrived from the environment or from the registry.
Alternatively you can examine if the file has a true name or (still) is named Book nnn which means it hasn't been saved before; this removes the need to reserve a timestamp cell in your workbook
Here are a couple of functions you could use to get your id. If you put this inside a vba module on your template you will be able to call the functions from the worksheets or other vba code (e.g. in workbook just enter '=get_id()', in vba you would do something like 'id = get_id()' to call this:
Option Explicit
Public Function lpad(string1, padded_length, _
Optional pad_string = " ")
Dim chars
chars = padded_length - Len(string1)
lpad = WorksheetFunction.Rept(pad_string, chars) & string1
End Function
Public Function get_id()
Dim user
Dim YYYYMMDD
Dim hhmmss
user = Environ("username")
YYYYMMDD = Year(Now()) & lpad(Month(Now()), 2, 0) & lpad(Day(Now()), 2, 0)
hhmmss = lpad(Hour(Now()), 2, 0) & lpad(Minute(Now()), 2, 0) & lpad(Second(Now()), 2, 0)
get_id = user & "-" & YYYYMMDD & "-" & hhmmss
End Function
The lpad function is just for formatting (so that you get 07 for July instead of 7 etc.). I have also added something here to set the user to the windows environment variable for the current user's name, but if you want to promt the user instead this part could easily be replaced.
Let me know if you have any questions.

Excel macro to change location of .cub files used by pivot tables? (to allow .xls files that depend on .cub files to be moved)

I often use Excel with pivot tables based on .cub files for OLAP-type analysis. This is great except when you want to move the xls and you realise internally it's got a non-relative reference to the location of the .cub file. How can we cope with this - ie make it convenient to move around xls files that depend on .cub files?
The best answer I could come up with is writing a macro that updates the pivot tables' reference to the .cub file location....so I'll pop that in an answer.
Here's the macro I ended up with. Clearly this makes some assumptions that might not be right for you, e.g. it updates all pivot tables in the workbook to use the same .cub file.
It loops through the workbook's Pivot Table connections to use a .cub file with
the same name as this .xls file, in the same directory. This assumes that the PivotCaches are not using LocalConnections - check that ActiveWorkbook.PivotCaches(1).UseLocalConnection = False.
Sub UpdatePivotTableConnections()
Dim sNewCubeFile As String
sNewCubeFile = ActiveWorkbook.Path & Replace(ActiveWorkbook.Name, ".xls", ".cub", , , vbTextCompare)
Dim iPivotCount As Integer
Dim i As Integer
iPivotCount = ActiveWorkbook.PivotCaches.Count
' Loop through all the pivot caches in this workbook. Use some
' nasty string manipulation to update the connection.
For i = 1 To iPivotCount
With ActiveWorkbook.PivotCaches(i)
' Determine which cub file the PivotCache is currently using
Dim sCurrentCubeFile As String
Dim iDataSourceStartPos As Integer
Dim iDataSourceEndPos As Integer
iDataSourceStartPos = InStr(1, .Connection, ";Data Source=", vbTextCompare)
If iDataSourceStartPos > 0 Then
iDataSourceStartPos = iDataSourceStartPos + Len(";Data Source=")
iDataSourceEndPos = InStr(iDataSourceStartPos, .Connection, ";", vbTextCompare)
sCurrentCubeFile = Mid(.Connection, iDataSourceStartPos, iDataSourceEndPos - iDataSourceStartPos)
' If the PivotCache is using a different cub file then update the connection to use the new one.
If sCurrentCubeFile <> sNewCubeFile Then
.Connection = Left(.Connection, iDataSourceStartPos - 1) & sNewCubeFile & Right(.Connection, Len(.Connection) - iDataSourceEndPos + 1)
End If
End If
End With
Next i
End Sub

Create PowerPoint charts from MS Access queries

I have an Access db to track metrics and "number crunch" data to build PowerPoint presentations. I do about 40 presentations per month, and they are 98% charts.
I run queries one at a time (using SQL statements), take the resulting data and copy it into an Excel template (I made a mock table in this "template" so the chart is already built and formatted), then copy the chart as a picture into a PowerPoint template.
So there is a lot of manual work.
How can I run multiple queries in Access with VBA on the same dataset/table (I have to do sales by quarter, by month, by region, by state, by site and all of these are Top5 aggregate, hence the reasons for the charts), and then send the resulting data to a specific Excel workbook, while defining what goes into what cell range?
If I get all the data into Excel, and have the charts ready to go, is there some VBA that will take the charts from Excel (activeworksheet) and paste them into PowerPoint as pictures in a quad view layout?
Can I do the same thing with an Access to PowerPoint approach and cut out Excel?
I am a novice at best.
You don't need to use Excel at all ! Use MS Access Charts in a report and some VBA code to put them into Powerpoint directly. There is already an example here
One "gotcha" is if you generate graphs in a group ie you design the report with a graph that is inside a group - so when you run the report you will get numerous graphs created.
It is a bit tricky to get hold of each of these graphs and drop them into Powerpoint but here is some code that will take care of it. This works in Access 2003
'Loop through all the controls in this report and pickout all the graphs
For Each c In pReport.Controls
'Graphs initially appear to be in an Object Frame
If TypeOf c Is ObjectFrame Then
'Check the Class of the object to make sure its a Chart
If Left$(c.Class, 13) = "MSGraph.Chart" Then
'Check if this graph must be cloned (required if the graph is in a group in the MS Access report)
If Not IsGraphToBeCloned(pReport.Name, c.ControlName) Then
InsertGraphToPptSlide c, "", pReport.Name
Else
InsertGraphGroupToPpt pReport.Name, c
End If
End If
End If
Next
This will find all the graphs in the report, if the graph is in a group then we call the InsertGraphGroupToPPt function.
The trick here is that we know we have the same base graph multiple times - but populated with different data. So in Powerpoint what you need to do is paste the base graph into powerpoint slides n times - where n is the number of groups and then update the graphs query properties
eg
Function UpdateGraphInPowerpoint(sql As String, OrigGraph As ObjectFrame, Groups As dao.Recordset, GroupName As String, ReportName As String) As Boolean
//Copyright Innova Associates Ltd, 2009
On Error GoTo ERR_CGFF
On Error GoTo ERR_CGFF
Dim oDataSheet As DataSheet
Dim Graph As Graph.Chart
Dim lRowCnt, lColCnt, lValue As Long, CGFF_FldCnt As Integer
Dim CGFF_Rs As dao.Recordset
Dim CGFF_field As dao.Field
Dim CGFF_PwrPntloaded As Boolean
Dim lheight, lwidth, LLeft, lTop As Single
Dim slidenum As Integer
Dim GraphSQL As String
Dim lGrpPos As Long
'Loop thru groups
Do While Not Groups.EOF
'We want content to be added to the end of the presentation - so find out how many slides we already have
slidenum = gPwrPntPres.Slides.Count
OrigGraph.Action = acOLECopy 'Copy to clipboard
slidenum = slidenum + 1 'Increment the Ppt slide number
gPwrPntPres.Slides.Add slidenum, ppLayoutTitleOnly 'Add a Ppt slide
'On Error Resume Next 'Ignore errors related to Graph caption
gPwrPntPres.Slides(slidenum).Shapes(1).TextFrame.TextRange.Text = ReportName & vbCrLf & "(" & Groups.Fields(0).Value & ")" 'Set slide title to match graph title
gPwrPntPres.Slides(slidenum).Shapes(1).TextFrame.TextRange.Font.Size = 16
gPwrPntPres.Slides(slidenum).Shapes.Paste 'Paste graph into ppt from clipboard
Set Graph = gPwrPntPres.Slides(slidenum).Shapes(2).OLEFormat.Object
Set oDataSheet = Graph.Application.DataSheet ' Set the reference to the datasheet collection.
oDataSheet.Cells.Clear ' Clear the datasheet.
GraphSQL = Replace(sql, "<%WHERE%>", " where " & GroupName & " = '" & Groups.Fields(0).Value & "'")
Set CGFF_Rs = ExecQuery(GraphSQL)
CGFF_FldCnt = 1
' Loop through the fields collection and get the field names.
For Each CGFF_field In CGFF_Rs.Fields
oDataSheet.Cells(1, CGFF_FldCnt).Value = CGFF_Rs.Fields(CGFF_FldCnt - 1).Name
CGFF_FldCnt = CGFF_FldCnt + 1
Next CGFF_field
lRowCnt = 2
' Loop through the recordset.
Do While Not CGFF_Rs.EOF
CGFF_FldCnt = 1
' Put the values for the fields in the datasheet.
For Each CGFF_field In CGFF_Rs.Fields
oDataSheet.Cells(lRowCnt, CGFF_FldCnt).Value = IIf(IsNull(CGFF_field.Value), "", CGFF_field.Value)
CGFF_FldCnt = CGFF_FldCnt + 1
Next CGFF_field
lRowCnt = lRowCnt + 1
CGFF_Rs.MoveNext
Loop
' Update the graph.
Graph.Application.Update
DoEvents
CGFF_Rs.Close
DoEvents
Groups.MoveNext
Loop
UpdateGraphInPowerpoint = True
Exit Function
End Function
Since you are a novice, perhaps you should break the task down into parts and automate the parts one at a time. Each step will provide benefits (i.e. time savings) and you can learn as you go.
It is hard to make specific recommendations based upon lack of specific information (what version etc.). That having been said, perhaps a good first step would be to link the Excel tables to the access queries so that the spreadsheets can auto-update every month and you will not have to cut and paste data from Access into Excel. You can do this linking entirely within Excel.
If you are using Excel 2007 click on "Data" in the Ribbon and then click on "From Access".
What you're asking is a lot of work:
Via VBA you'd have to open Excel (Excel Application manipulation from Access) , update your charts (Range manipulation, Data Update) if you have the rights then I would suggest having your pivot charts connected to the Access data and not pasted into the workbook, nevertheless I've been in enough situations where that was not possible. Then you would have to open your PowerPoint presentation and copy from the Excel to the PowerPoint. I've done all of these and know how much work it can save by creating a macro (via VBA) to do this. It's a lot of code.

Creating tables for copy from Word to Excel

So, I needed to take some data done in MS Word tables, and manipulate in excel.
I decided to get it from word to excel via a VBA subroutine to "save time".
My source word document contained like twentysomething tables.
I took my source document's tables, extracted my data and made a new document, with a new table, only needing me to copy and paste it into excel.
However, while the final table before copy looks good in word. When i copy it to excel, it breaks up the cells that contain whole paragraphs into separate cells.
As most excel peeps would know, even though a solution looks like in excel, doing a merge and center - that only preserves the content in the uppermost cell in the selection!
So, any advice, on either a better merge and center, or a better "time saver" alltogether, would be great.
Here's a sample of the code so far:
Sub First()
Dim tableLength, tableIndex
tableLength = ThisDocument.Tables.Count
Dim tblReport As Table
Dim docReport As Document
Set docReport = Documents.Add
Set tblReport = docReport.Tables.Add(Selection.Range, 1, 2)
With tblReport
Dim fieldOne, subvalueAription, subvalueA, subvalueB, subvalueC
For tableIndex = 1 To tableLength
fieldOne = ThisDocument.Tables(tableIndex).Rows(2).Cells(2).Range.Text
subvalueA = Trim(ThisDocument.Tables(tableIndex).Rows(4).Cells(2).Range.Text)
subvalueB = "A: " & Trim(ThisDocument.Tables(tableIndex).Rows(5).Cells(2).Range.Text)
subvalueC = "B: " & Trim(ThisDocument.Tables(tableIndex).Rows(6).Cells(2).Range.Text)
subvalueAription = subvalueA & subvalueB & subvalueC & "C: "
Dim rowNext As row
Set rowNext = .Rows.Add
rowNext.Cells(1).Range.Text = fieldOne
rowNext.Cells(2).Range.Text = subvalueA & subvalueB & subvalueC
Next
End With
End Sub
Excel uses a different line terminator than Word. In order to avoid the problem with the text from the Word table being split over several Excel cells, you need to handle the line terminator conversion yourself.
'Word > Excel
newText = Replace(wordText, vbCrLf, vbLf)
I'm posting this by memory, but that's the root of that problem.

Resources