Link to home
Start Free TrialLog in
Avatar of CFMI
CFMIFlag for United States of America

asked on

MS Access VBA to include Access Table field

Hello Experts,

I am trying to read in an ACCESS Table field but my attempt delivers the message, “Sub or Function not defined“.  Funny, it excepts the first ACCESS field (SpreadsheetName).  Below displays the problem and the code.

              Set shtToCopy = wkbSource.Sheets(rs("SSTab"))

And the VBA:
Private Sub TestCopy_Click()
Dim wkbSource As Workbook
Dim wkbDest As Workbook
Dim shtToCopy As Worksheet
Dim rs As Recordset
Dim xl As Object
Dim SpreadsheetName As String
Dim SSTab As String
Dim ID As Field

Set xl = CreateObject("Excel.Application")
xl.Visible = True
Set rs = CurrentDb.OpenRecordset("TblReports")

Do While Not (rs.EOF)
    Set wkbSource = xl.Workbooks.Open(rs("SpreadsheetName"))
    Set wkbDest = xl.Workbooks.Open("H:\PDF\MasterReport88.xlsx")
        'Makes a copy of "Sheet1"
    Set shtToCopy = wkbSource.Sheets(rs("SSTab"))           'Sheets("Output 1")  Sheets(rs("SSTab"))
    shtToCopy.Copy wkbDest.Sheets(1)
       
           'Closes "wkbDest" workbook and saves the copied sheeet
    wkbSource.Close False
  rs.MoveNext
Loop

wkbDest.Close SaveChanges:=True
Set wkbSource = Nothing
Set wkbDest = Nothing

    Beep
    MsgBox "Worksheet was copied"

End Sub
Avatar of omgang
omgang
Flag of United States of America image

Try

Set rs = CurrentDb.OpenRecordset("TblReports")

rs.MoveFirst

Do While Not (rs.EOF)


OM Gang
Avatar of CFMI

ASKER

This modification presents the message, "Run-time error 13", Type mismatch" and points to the same code:
          Set shtToCopy = wkbSource.Sheets(rs("SSTab"))
I'm getting the same error as you.  Apparently we can't pass a sheet name for the argument.  Works with sheet index value.
Working on it.
OM Gang


Public Function TestExcel()

On Error GoTo Err_TestExcel

    Dim xl As New Excel.Application
    Dim wkbSource As Workbook
    Dim wkbDest As Workbook
    Dim shtToCopy As Worksheet
   
    Dim rs As DAO.Recordset
    Set rs = CurrentDb.OpenRecordset("tblExcel")
    rs.MoveFirst
   
    Set wkbSource = xl.Workbooks.Open(rs("Workbook"))
    Debug.Print wkbSource.Name
   
    'Set shtToCopy = wkbSource.Worksheets(rs("Worksheet"))
    'Set shtToCopy = wkbSource.Sheets(rs("Worksheet"))
    Set shtToCopy = wkbSource.Sheets(1)
    Debug.Print shtToCopy.Name

   

Exit_TestExcel:
    Set shtToCopy = Nothing
    Set wkbSource = Nothing
    Set xl = Nothing
    Exit Function

Err_TestExcel:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure TestExcel of Module Module9"
    Resume Exit_TestExcel

End Function
SOLUTION
Avatar of omgang
omgang
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Have you tried
Set shtToCopy = wkbSource.Sheets(rs("SSTab")).Sheet
Avatar of CFMI

ASKER

Just tried:
 Set shtToCopy = wkbSource.Sheets(rs("SSTab")).Sheet
and received an error message, :"Type Mismatch"
@CFMI, have you tried the solution/work around I suggested?
OM Gang
Avatar of CFMI

ASKER

Hello,
I am using your code but receiving an error message, "3265 (Item not found in this collection.) in procedure TestExcel of Module Module9".  Unfortunately, I was just pulled to handle a higher priority and will try again on Monday - have a great weekend!
OK
ASKER CERTIFIED SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Interesting.  I hadn't thought to try that (assign the value to a variable first).  Good find.
OM Gang
Avatar of CFMI

ASKER

So close, no errors but the sheet isn't copied even with the message appearing, "Worksheet was copied".  Also, when I open the spreadsheet, "MasterReport88.xlsx", a Read/Write message appears.

On Error GoTo Err_TestExcel
    Dim xl As New Excel.Application
    Dim wkbSource As Workbook
    Dim wkbDest As Workbook
    Dim shtToCopy As Excel.Worksheet
    Dim i As Integer
    Dim shtName As String
    Dim SSName As String
    Dim SSTab As String
    Dim rs As DAO.Recordset
   
    Set rs = CurrentDb.OpenRecordset("TblReports")
    rs.MoveFirst
   
    Set wkbSource = xl.Workbooks.Open(rs("SSName"))
    shtName = rs!SSTab
    Debug.Print wkbSource.Name
   
    Set wkbDest = xl.Workbooks.Open("H:\PDF\MasterReport88.xlsx")
   
    Do While Not (rs.EOF)
    Set wkbSource = xl.Workbooks.Open(rs("SSName"))
    shtName = rs!SSTab
    Set shtToCopy = wkbSource.Sheets(shtName)           'Makes a copy of "Sheet1"
    shtToCopy.Copy wkbDest.Sheets(1)
       
  rs.MoveNext
Loop
       
    Debug.Print shtToCopy.Name
   
Exit_TestExcel:
           'Closes "wkbDest" workbook and saves the copied sheeet
    wkbSource.Close False
    Set wkbDest = Nothing
    Set shtToCopy = Nothing
    Set xl = Nothing
       
Beep
    MsgBox "Worksheet was copied"
    Exit Sub

Err_TestExcel:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure TestExcel of Module Module9"
    Resume Exit_TestExcel
Try
    shtToCopy.Copy After:=wkbSource.Sheets(wkbSource.Sheets.Count)


The Excel Worksheet.Copy command creates a copy and places it in a location.  It doesn't accept a sheet name for an argument but, instead, and index of where we want to place it.  My example places the copy after the last workseet in the list.

OM Gang
Avatar of CFMI

ASKER

Unfortunately, no worksheets are copied into the destination, "MasterReport88.xlsx".
Avatar of CFMI

ASKER

Experts,

The below code displays the final spreadsheet, “MasterReport88.xlsx” with all of the worksheets copied however when I attempt to save the file an error message appears, “Errors were detected while saving H:\PDF\MasterReport88.xlsx.  Microsoft Excel may be able to save the file by removing or repairing some features. To make the repair in a new file, click continue.  To cancel saving the file, click.

The save never happens so I manually selected save as and it saved PERFECT with a xls extension - this is great but I am not sure about the saveas code; I tried: wkbDest.SaveAs "H:\PDF\MasterReport.xls" but that didn't work.  Please share suggestions.

Private Sub TestCopy_Click()
Dim xl As New Excel.Application
Dim wkbSource As Workbook
Dim wkbDest As Workbook
Dim shtToCopy As Excel.Worksheet
Dim rs As Recordset
Dim SSName As String
Dim SSTab As String
Dim shtName As String
Set xl = CreateObject("Excel.Application")
xl.Visible = True
Set rs = CurrentDb.OpenRecordset("TblReports")
rs.MoveFirst
Set wkbDest = xl.Workbooks.Open("H:\PDF\MasterReport88.xlsx")
Do While Not (rs.EOF)
    shtName = rs!SSTab
    Set wkbSource = xl.Workbooks.Open(rs("SSName"))
    Set shtToCopy = wkbSource.Sheets(shtName)           'Sheets("Output 1")  Sheets(rs("SSTab"))
    shtToCopy.Copy After:=wkbSource.Sheets(wkbSource.Sheets.Count)
        Set shtToCopy = wkbSource.Sheets(shtName)           'Makes a copy of "Sheet1"
    shtToCopy.Copy wkbDest.Sheets(1)
    Set shtToCopy = wkbSource.Sheets(shtName)
    wkbSource.Close False
  rs.MoveNext
Loop
wkbDest.SaveAs "H:\PDF\MasterReport.xls"
wkbDest.Close SaveChanges:=True
Set wkbSource = Nothing
Set wkbDest = Nothing
    Beep
    MsgBox "Worksheet was copied"

End Sub
Avatar of CFMI

ASKER

The provided code allowed using a MS Access Table to insert workbook names and worksheet titles.