asked on

Access VBA Error: Run Time Error '-2147221080(800401a8)': Automation Error

I have a report that imports a data from an Excel spreadsheet into an Access database. Then I run a series of macros (see below code). Everything was great until I upgraded from Office 2010 to Office 2013. Now when I run the macros, I receive a Run Time Error '-2147221080(800401a8)': Automation Error. Debugging highlights row 528 of the code (xlSheet.Range("A2").CopyFromRecordset rs). I inherited this program and know next to nothing about VB. Can anyone please help me to fix this? Thanks!

Option Compare Database
Private Const bolDEBUG As Boolean = False
Private xlBooks(3) As Excel.Workbook

Private Function buildInsert(int_value As Integer, str_Region As String, str_criteria As String, rs() As String, Optional strInverse As String = "") As String
'***** Create the INSERT SQL string that is used to drop the manipulated data into the proper tables *****
Dim strSQL As String
Select Case int_value
Case 1 '10 values
strSQL = "INSERT INTO [" & str_criteria & " " & str_Region & "] VALUES ('" & rs(1) & "','" & rs(3) & "','" & rs(4) & "','" & rs(5) & "','" & rs(6) & "','" & rs(7) & "','" & rs(8) & "','" & rs(9) & "','" & rs(10) & "','" & rs(11) & "');"
Case 2 '11 values
strSQL = "INSERT INTO [" & str_criteria & " " & str_Region & "] VALUES ('" & rs(1) & "','" & rs(2) & "','" & rs(3) & "','" & rs(4) & "','" & rs(5) & "','" & rs(6) & "','" & rs(7) & "','" & rs(8) & "','" & rs(9) & "','" & rs(10) & "','" & rs(11) & "');"
Case 3
strSQL = "INSERT INTO [" & str_criteria & " " & str_Region & "] (Product,DistiName,Region,Country,StockActual,SalesOutFour,InvWeeksOnHandFour,SalesOutThirteen,InvWeeksOnHandThirteen,SixWeekStock,ExcessStock) SELECT Product, DistiName, Region, Country, StockActual, SalesOutFour, InvWeeksOnHandFour, SalesOutThirteen, InvWeeksOnHandThirteen, SixWeekStock, ExcessStock FROM [" & strInverse & " " & str_Region & "];"
Case 4
strSQL = "INSERT INTO [" & str_criteria & " " & str_Region & "] VALUES ('" & rs(1) & "','" & rs(3) & "','" & rs(4) & "','" & rs(2) & "','" & rs(12) & "','" & rs(13) & "','" & rs(5) & "','" & rs(6) & "','" & rs(7) & "','" & rs(8) & "','" & rs(9) & "','" & rs(10) & "','" & rs(11) & "');"
End Select

buildInsert = strSQL

End Function

Private Function buildSQL(int_value As Integer, str_Region As String, Optional sht_value As Integer = 0, Optional str_criteria As String = "", Optional productString As String = "", Optional skuString As String = "") As String
'***** Create the SQL Strings that pull the relevant data based on what sheet / table we're populating *****
Dim strSQL As String
Dim region As String
Dim sht_string As String

Select Case sht_value
Case 1
sht_string = "'Windows Client'"
Case 2
sht_string = "'Information Worker'"
Case 3
sht_string = "'Windows Server and Azure','SQL Server','Other Server & Tools'"
Case 4
sht_string = "'Windows Server and Azure','SQL Server','Other Server & Tools','Information Worker','Windows Client'"
End Select

Select Case int_value
Case -2
strSQL = "SELECT DISTINCT [Field1], [Field5], [Field2], [Field6], [Field7] FROM (Select * from [Data - no pivot] where [Field3] IN (" & sht_string & ")) AS [%$##@_Alias] WHERE [Field4] = '" & str_Region & "';"
Case -1
strSQL = "SELECT DISTINCT [Field1], [Field5] FROM (Select * from [Data - no pivot] where [Field3] IN (" & sht_string & ")) AS [%$##@_Alias] WHERE [Field4] = '" & str_Region & "';"
Case 0
strSQL = "DELETE * from [" & str_criteria & " " & str_Region & "]"
Case 1
strSQL = "SELECT DISTINCT [Field1], [Field5], [Field2] FROM (Select * from [Data - no pivot] where [Field3] IN (" & sht_string & ")) AS [%$##@_Alias] WHERE [Field4] = '" & str_Region & "';"
Case 2
strSQL = "SELECT sum(Field33) as 'Stock Actual', (sum(Field20) + sum(Field18) + sum(Field19) + sum(Field17)) as 'Total - Four Week', (sum(Field8) + sum(Field9) + sum(Field10) + sum(Field11) + sum(Field12) + sum(Field13) + sum(Field14) + sum(Field15) + sum(Field16) + sum(Field17) + sum(Field18) + sum(Field19) + sum(Field20)) as 'Total - Thirteen Week' from [Data - no pivot] WHERE Field1 = '" & str_criteria & "' and Field3 in (" & sht_string & ") and Field4 = '" & str_Region & "';"
Case 3
strSQL = "SELECT sum(Field33) as 'Stock Actual', (sum(Field20) + sum(Field18) + sum(Field19) + sum(Field17)) as 'Total - Four Week', (sum(Field8) + sum(Field9) + sum(Field10) + sum(Field11) + sum(Field12) + sum(Field13) + sum(Field14) + sum(Field15) + sum(Field16) + sum(Field17) + sum(Field18) + sum(Field19) + sum(Field20)) as 'Total - Thirteen Week' from [Data - no pivot] WHERE Field1 = '" & str_criteria & "' and Field3 in (" & sht_string & ") and Field4 = '" & str_Region & "' and Field2 = '" & productString & "';"
Case 4
strSQL = "SELECT sum(Field33) as 'Stock Actual', (sum(Field20) + sum(Field18) + sum(Field19) + sum(Field17)) as 'Total - Four Week', (sum(Field8) + sum(Field9) + sum(Field10) + sum(Field11) + sum(Field12) + sum(Field13) + sum(Field14) + sum(Field15) + sum(Field16) + sum(Field17) + sum(Field18) + sum(Field19) + sum(Field20)) as 'Total - Thirteen Week' from [Data - no pivot] WHERE Field1 = '" & str_criteria & "' and Field3 in (" & sht_string & ") and Field4 = '" & str_Region & "' and Field6 = '" & skuString & "';"
End Select

buildSQL = strSQL

End Function

Private Sub TableCreate(str_Region As String, str_criteria As String)
'***** Create the proper table(s) using the passed criteria, for use with other sql queries. IE: Name format is important
DoCmd.SetWarnings (False)

'This command creates the table "tstClient United States" and adds 0 rows to it, since 0 will NEVER equal 1
DoCmd.RunSQL ("SELECT * INTO [" & str_criteria & " " & str_Region & "] from [" & str_criteria & " Master] where 0=1;")
DoCmd.SetWarnings (True)

End Sub

Private Function getRegion() As ADODB.Recordset
'***** Pulls a distinct recordset of regions that we use to determine what / how many regions we're making reports for
Dim rs_distinctDistiList As ADODB.Recordset, rs_DistiBreakdown As ADODB.Recordset, rs_DistiInsert As ADODB.Recordset

Set rs_distinctDistiList = New ADODB.Recordset
Set rs_DistiBreakdown = New ADODB.Recordset
Set rs_DistiInsert = New ADODB.Recordset

rs_distinctDistiList.Open "SELECT DISTINCT [Field4] FROM [Data - no pivot];", CurrentProject.Connection, adOpenDynamic, adLockOptimistic

Set getRegion = rs_distinctDistiList

End Function

Private Sub doAllInsert(sheetValue As Integer, criteria As String)
'*************************************************************************************************************
'This is the Meat and Potatoes of the tool
'It loops 4 times, once for each style of sheet. IE: Rollup, disti by and by disti, weekly rollup, and sku
'It pulls all relevant data for whatever region we're working with, and whatever group. IE: Client, IW, Server
'It then inserts the information into the proper tables for use later when we export to Excel
'*************************************************************************************************************

Dim rs_distinctDistiList As ADODB.Recordset, rs_DistiBreakdown As ADODB.Recordset, rs_DistiInsert As ADODB.Recordset
Dim str_criteria As String, str_SQL As String, str_Region As String, str_Country As String, str_product As String, str_sheet As String, str_SKU As String, str_SKUDesc As String, distiByName As String, strStore As String
Dim lng_4week As Double, lng_13week As Double, lng_StockActual As Double, lng_InvWeeksOnHand4 As Double
Dim lng_InvWeeksOnHand13 As Double, lng_6weekStock As Double, lng_excessStock As Double
Dim region As Integer
Dim valueArray(13) As String
Dim runAlready As Boolean

Set rs_distinctDistiList = New ADODB.Recordset
Set rs_DistiBreakdown = New ADODB.Recordset
Set rs_DistiInsert = New ADODB.Recordset

strStore = criteria

For totalLoop = 1 To 4 '1 = rollup, 2 = Disti by, 3 = weekly rollup, 4 = sku

'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
Select Case totalLoop
Case 1
str_sheet = strStore
Case 2
str_sheet = strStore & " by Disti"
distiByName = "Disti by " & strStore 'strip out the "by Disti" part, for modification
Case 3
str_sheet = "Weekly Roll Up"
Case 4
str_sheet = "SKU"
End Select
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

'***************** Dynamic Region Aquisition **********************
Set rs_Regions = getRegion

rs_Regions.MoveFirst
While Not rs_Regions.EOF
If rs_Regions.Fields.Item(0).Value <> "" Then
str_Region = rs_Regions.Fields.Item(0).Value
'*********** DONE Dynamic Region Aquisition DONE ****************

'Call tableClear(str_region, str_sheet)
'Call tableClear(str_region, distiByName)

'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

Call TableCreate(str_Region, str_sheet)

Select Case totalLoop
Case 1
str_SQL = buildSQL(-1, str_Region, sheetValue, str_sheet)
Case 2
Call TableCreate(str_Region, distiByName)
str_SQL = buildSQL(1, str_Region, sheetValue, str_sheet)
Case 3
str_SQL = buildSQL(-1, str_Region, 4, str_sheet)
Case 4
str_SQL = buildSQL(-2, str_Region, 4, str_sheet)
End Select
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
On Error Resume Next
rs_distinctDistiList.Open str_SQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
rs_distinctDistiList.MoveFirst

While Not rs_distinctDistiList.EOF 'Loop through all disti's to get total values

'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
DoEvents

Select Case totalLoop
Case 2
str_product = rs_distinctDistiList.Fields.Item(2).Value
Case 4
str_product = rs_distinctDistiList.Fields.Item(2).Value
str_SKU = rs_distinctDistiList.Fields.Item(3).Value
str_SKUDesc = rs_distinctDistiList.Fields.Item(4).Value
End Select
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

str_Country = rs_distinctDistiList.Fields.Item(1).Value
criteria = rs_distinctDistiList.Fields.Item(0).Value

If Not inBadList(criteria) Then

'by Disti query
'*********************************
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
Select Case totalLoop
Case 1
str_SQL = buildSQL(2, str_Region, sheetValue, criteria)
Case 2
str_SQL = buildSQL(3, str_Region, sheetValue, criteria, str_product)
Case 3
str_SQL = buildSQL(2, str_Region, 4, criteria)
Case 4
str_SQL = buildSQL(4, str_Region, 4, criteria, , str_SKU)
End Select
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
If rs_DistiBreakdown.State = adStateOpen Then rs_DistiBreakdown.Close
rs_DistiBreakdown.Open str_SQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic

rs_DistiBreakdown.MoveFirst

While Not rs_DistiBreakdown.EOF

lng_StockActual = 0
lng_4week = 0
lng_13week = 0

If Not rs_DistiBreakdown.Fields.Item(0).Value Then lng_StockActual = rs_DistiBreakdown.Fields.Item(0).Value
If Not rs_DistiBreakdown.Fields.Item(1).Value Then lng_4week = rs_DistiBreakdown.Fields.Item(1).Value
If Not rs_DistiBreakdown.Fields.Item(2).Value Then lng_13week = rs_DistiBreakdown.Fields.Item(2).Value

lng_4week = lng_4week / 4
lng_13week = lng_13week / 13

If lng_4week > 0 Then
lng_InvWeeksOnHand4 = lng_StockActual / lng_4week
Else
lng_InvWeeksOnHand4 = 0
End If

If lng_13week > 0 Then
lng_InvWeeksOnHand13 = lng_StockActual / lng_13week
Else
lng_InvWeeksOnHand13 = 0
End If

lng_6weekStock = lng_13week * 6
lng_excessStock = lng_6weekStock - lng_StockActual

'populate Array
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
valueArray(1) = criteria 'Disti Name
valueArray(2) = str_product 'Product
valueArray(3) = str_Region 'Region
valueArray(4) = str_Country 'Country
valueArray(5) = lng_StockActual & "" 'Stock Actual
valueArray(6) = lng_4week & "" 'Sales Out 4 week
valueArray(7) = lng_InvWeeksOnHand4 & "" 'Inventory weeks on hand 4
valueArray(8) = lng_13week & "" 'Sales Out 13 week
valueArray(9) = lng_InvWeeksOnHand13 & "" ' Inventory weeks on hand 13
valueArray(10) = lng_6weekStock & "" 'Six week stokc
valueArray(11) = lng_excessStock & "" 'Excess Stock
Select Case totalLoop
Case 4
valueArray(12) = str_SKU
valueArray(13) = str_SKUDesc
End Select
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

'Client / IW / Server Roll-up
'*****************************
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
Select Case totalLoop
Case 1
str_SQL = buildInsert(1, str_Region, str_sheet, valueArray)
Case 2
str_SQL = buildInsert(2, str_Region, str_sheet, valueArray)
Case 3
str_SQL = buildInsert(1, str_Region, str_sheet, valueArray)
Case 4
str_SQL = buildInsert(4, str_Region, str_sheet, valueArray)
End Select
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
rs_DistiInsert.Open str_SQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
'rs_DistiInsert.Close
'*****************************

rs_DistiBreakdown.MoveNext
'rs_DistiBreakdown.Close

Wend
End If
rs_distinctDistiList.MoveNext
Wend

'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
Select Case totalLoop
Case 2
str_SQL = buildInsert(3, str_Region, distiByName, valueArray, str_sheet)
rs_DistiInsert.Open str_SQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
End Select
'/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

rs_DistiBreakdown.Close
rs_distinctDistiList.Close

'***************** Dynamic Region Aquisition **********************
End If
rs_Regions.MoveNext

Wend

If totalLoop = 3 Then 'This is a weekly roll-up, and that's what we need for the Inventory report... let's call the sub now
Call makeInventoryReport
End If
'*********** DONE Dynamic Region Aquisition DONE ****************

Next totalLoop

'Insert Inventory report here

rs_Regions.Close
Set rs_Regions = Nothing
End Sub

Private Sub makeInventoryReport()

'

End Sub

Private Sub InventoryWorksheetCopy(DBFullName As String, TableName As String, FieldName As String, TargetRange As Range)
'This sub copies all tables to the proper worksheet
Dim strFilename As String, strRegion As String, strSheetName As String
Dim rs_Regions As ADODB.Recordset
Dim regionCount As Integer, rowCount As Integer
Dim xlApp As Excel.Application, xlWB As Excel.Workbook, xlSheet As Excel.Worksheet, xlRng As Excel.Range
Dim db As Database, rs As Recordset, intColIndex As Integer
Set xlApp = New Excel.Application

'***************** Dynamic Region Aquisition **********************
Set rs_Regions = getRegion

rs_Regions.MoveFirst
While Not rs_Regions.EOF
If rs_Regions.Fields.Item(0).Value <> "" Then
strRegion = rs_Regions.Fields.Item(0).Value
'*********** DONE Dynamic Region Aquisition DONE ****************

With xlApp
.Visible = True
Set xlWB = .Workbooks.Open(GetDBPath & "invBlankWorkbook.xlsm", , False)
End With

Set db = Application.CurrentDb

rowCount = 2

'Itteration Loop for all tables
For a = 0 To db.TableDefs.Count - 1

If bolDEBUG Then 'Do this stuff if we're debugging

Else 'Do this stuff if we're NOT debugging

If InStr(1, db.TableDefs(a).Name, "msys") = False And InStr(1, db.TableDefs(a).Name, "~") = False And db.TableDefs(a).Name <> "Data" Then
If InStr(1, db.TableDefs(a).Name, "Weekly Roll Up") <> False Then
strSheetName = "Inventory"

'If Right(strSheetName, Len(strRegion)) = strRegion Then

'strSheetName = Left(strSheetName, (Len(strSheetName) - (Len(strRegion) + 1)))

Set xlSheet = xlWB.Sheets(strSheetName)

Set rs = db.OpenRecordset(workSheetCopySQL(db.TableDefs(a).Name))

xlSheet.Range("A" & rowCount).CopyFromRecordset rs

rowCount = xlApp.Run("findLastRow", xlSheet) + 1

'End If
End If
End If

End If

Next a

Set rs = Nothing
db.Close

xlApp.Run ("doFormat")

xlApp.ActiveWorkbook.Close SaveChanges:=True, FileName:=genFileName("Inventory")
xlApp.Quit
GoTo finished
'***************** Dynamic Region Aquisition **********************
End If

rs_Regions.MoveNext

Wend
'*********** DONE Dynamic Region Aquisition DONE ****************
finished:
rs_Regions.Close
Set rs_Regions = Nothing
Set db = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
Set xlSheet = Nothing

End Sub

Private Function getRegions(region As Integer) As String
' --- DEPRICATED ---

Open in new window

Dim str_Region As String

Select Case region
Case 1
str_Region = "United States"
Case 2
str_Region = "Canada"
Case 3
str_Region = "Latam"
End Select
getRegions = str_Region

End Function

Public Sub processData()
'On Error Resume Next

'Main sub
Dim sheetValue As Integer
Dim sheetString As String
Dim startTime, endTime

startTime = Now()
Call tableDelete

For sheetValue = 1 To 3 'This will be either Client, IW, or Server information
DoEvents
Select Case sheetValue
Case 1
sheetString = "Client"
Case 2
sheetString = "IW"
Case 3
sheetString = "Server"
End Select

Call doAllInsert(sheetValue, sheetString)

Next sheetValue

Call startWorksheetCopy

endTime = Now()

Call MsgBox("Process completed in " & Format(endTime - startTime, "HH:MM:SS") & " time", vbOKOnly, "Process Complete")

End Sub

Private Sub tableClear(str_Region As String, criteria As String)
'--- DEPRICATED ---
Dim rs_distinctDistiList As ADODB.Recordset

Set rs_distinctDistiList = New ADODB.Recordset

str_SQL = buildSQL(0, str_Region, , criteria)
rs_distinctDistiList.Open str_SQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic

'str_SQL = buildSQL(-1, str_region, , criteria)
'rs_distinctDistiList.Open str_SQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic

End Sub

Private Function GetDBPath() As String
'Get the path location of the database
Dim strFullPath As String
Dim I As Integer

strFullPath = CurrentDb().Name

For I = Len(strFullPath) To 1 Step -1
If Mid(strFullPath, I, 1) = "\" Then
GetDBPath = Left(strFullPath, I)
Exit For
End If
Next
End Function

Private Sub tableDelete()
'Deletes all non-master and non-Data no pivot tables
Dim db As Database

Set db = Application.CurrentDb

For a = 0 To db.TableDefs.Count - 1
DoEvents
If InStr(1, db.TableDefs(a).Name, "msys") = False And InStr(1, db.TableDefs(a).Name, "~") = False And db.TableDefs(a).Name <> "Data" Then
If InStr(1, db.TableDefs(a).Name, "Master") = 0 And InStr(1, db.TableDefs(a).Name, "no pivot") = 0 Then
'Call MsgBox(db.TableDefs(a).Name)
DoCmd.RunSQL ("DROP TABLE [" & db.TableDefs(a).Name & "];")
End If
End If
Next a
End Sub

Private Sub WorksheetCopy(DBFullName As String, TableName As String, FieldName As String, TargetRange As Range)
'This sub copies all tables to the proper worksheet
Dim strFilename As String, strRegion As String, strSheetName As String
Dim rs_Regions As ADODB.Recordset
Dim regionCount As Integer
Dim xlApp As Excel.Application, xlWB As Excel.Workbook, xlSheet As Excel.Worksheet, xlRng As Excel.Range
Dim db As Database, rs As Recordset, intColIndex As Integer
Set xlApp = New Excel.Application

'***************** Dynamic Region Aquisition **********************
Set rs_Regions = getRegion

rs_Regions.MoveFirst
While Not rs_Regions.EOF
If rs_Regions.Fields.Item(0).Value <> "" Then
strRegion = rs_Regions.Fields.Item(0).Value
'*********** DONE Dynamic Region Aquisition DONE ****************

With xlApp
.Visible = True
Set xlWB = .Workbooks.Open(GetDBPath & "blankWorkbook.xlsm", , False)
End With

Set db = Application.CurrentDb

'Itteration Loop for all tables
For a = 0 To db.TableDefs.Count - 1

If bolDEBUG Then 'Do this stuff if we're debugging

Else 'Do this stuff if we're NOT debugging

If InStr(1, db.TableDefs(a).Name, "msys") = False And InStr(1, db.TableDefs(a).Name, "~") = False And db.TableDefs(a).Name <> "Data" Then

strSheetName = db.TableDefs(a).Name

If Right(strSheetName, Len(strRegion)) = strRegion Then

strSheetName = Left(strSheetName, (Len(strSheetName) - (Len(strRegion) + 1)))

Set xlSheet = xlWB.Sheets(strSheetName)

Set rs = db.OpenRecordset(workSheetCopySQL(db.TableDefs(a).Name))

xlSheet.Range("A2").CopyFromRecordset rs

End If
End If

End If

Next a

Set rs = Nothing
db.Close

xlApp.Run ("doFormat")

xlApp.ActiveWorkbook.Close SaveChanges:=True, FileName:=genFileName(strRegion)
xlApp.Quit

'***************** Dynamic Region Aquisition **********************
End If
rs_Regions.MoveNext

Wend
'*********** DONE Dynamic Region Aquisition DONE ****************
rs_Regions.Close
Set rs_Regions = Nothing
Set db = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
Set xlSheet = Nothing

Call InventoryWorksheetCopy("C:\Users\v-ctows\Documents\Database1.accdb", "Data", "*", Nothing)

End Sub

Private Function workSheetCopySQL(tblName As String) As String
'Used with worksheet copy sub - generates the SQL string used to pull the information for Excel export
Dim strSQL As String

If InStr(1, tblName, "Disti By") > 0 Then
strSQL = "SELECT * from [" & tblName & "] ORDER BY Product, Country, Region, DistiName;"
ElseIf InStr(1, tblName, "By Disti") > 0 Then
strSQL = "SELECT * from [" & tblName & "] ORDER BY Country, Region, DistiName, Product;"
Else
strSQL = "SELECT * from [" & tblName & "] ORDER BY Country, Region, DistiName;"
End If

workSheetCopySQL = strSQL

End Function

Public Sub startWorksheetCopy()
'Called to start the worksheet copy
Call WorksheetCopy("C:\Users\v-ctows\Documents\Database1.accdb", "Data", "*", Nothing)
End Sub

Public Sub testInventoryWorksheetCopy()
'Called to start the worksheet copy
Call InventoryWorksheetCopy("C:\Users\v-ctows\Documents\Database1.accdb", "Data", "*", Nothing)
End Sub

Private Function inBadList(criteria As String) As Boolean
'Returns a boolean flag that determines if the passed string is in "the bad list"
If criteria = "LATIN AMERICA LLC" Then
inBadList = True
Else
inBadList = False
End If

End Function

Private Function getLastFriday() As Date

'Returns the date object for the previous friday
Dim currentDay As String
Dim dayOffset As Integer

currentDay = WeekdayName(Weekday(Now))
'MsgBox (currentDay)

Select Case currentDay

Case "Monday"
dayOffset = 3
Case "Tuesday"
dayOffset = 4
Case "Wednesday"
dayOffset = 5
Case "Thursday"
dayOffset = 6
Case "Friday"
dayOffset = 7
Case "Saturday"
dayOffset = 1
Case "Sunday"
dayOffset = 2

End Select

'Call MsgBox(DateAdd("d", (dayOffset * -1), Now))

getLastFriday = DateAdd("d", (dayOffset * -1), Now)

End Function

Private Function genFileName(Optional region As String = "") As String
'Generates a filename for use with the Excel Export. Uses an optional "Region" string as part of the name, if passed in
Dim strFilename As String

If region <> "" Then region = region & "_"

strFilename = "MSLI_WeeksOnHand_V3-" & region & Format(getLastFriday, "YYYYMMDD") & ".xlsm" 'Modify date format with new sub that returns previous friday

strFilename = Replace(strFilename, ":", ".")
strFilename = Replace(strFilename

Open in new window

, "/", ".")
strFilename = Replace(strFilename, " ", "_")

genFileName = strFilename

End Function

David L. Hansen

Put a break point on that line (the CopyFromRecordset line) and run it. When it hits there it will pause (before throwing the error) and you'll be able to move your mouse over the different items in that line of code and see what is missing (ie. perhaps the recordset "rs" is empty). Do that and let's see what is missing.

McQMom

ASKER

Thanks sl8rz - How do a put a break point in?

David L. Hansen

Watch this:
http://www.youtube.com/watch?v=6lQaXceRc-k

Jim Dettman (EE MVE)

Since this is a new version of Office, I would make sure that the application compiles and that your references are correct (VBA editor, tools/refereces).

I would do that before moving onto anything else.

Jim.

ASKER CERTIFIED SOLUTION

McQMom

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

McQMom

ASKER

It turned out that the error was caused by an Add In my company had me load. Once I accessed a device without the add in the reports ran with no errors.