How to add worksheets and rename with vba?

[deko]

I have a batch process that exports from Access. The problem I'm having is
creating (and naming) a new workbook, and inserting (and naming) the
multiple worksheets.

First, creating the Workbook (see line marked with ****). How do I create a
Workbook (and give the Workbook a specified name)? For example, in the
below function, I pass in "fld", which is a path to a directory. If the
user selected "new workbook" then I need to create a new Workbook in the
given directory and name the new Workbook somehow. Do I do this with Excel
automation? fso object?

Public Function GetSubFolders(fld As Scripting.Folder) As Boolean
Dim xlapp As Excel.Application
Dim xlwkbs As Excel.Workbooks
Dim xlwkb As Excel.Workbook
Dim fldSub As Scripting.Folder
Dim fso As Scripting.FileSystemObject
Dim strMdb As String
Dim strTarget As String
Dim bytOutput As Byte
Set xlapp = New Excel.Application
Set xlwkbs = xlapp.Workbooks
bytOutput = Forms("frmMain")!fraOutput
strTarget = Forms("frmMain")!txtOutput
Select Case bytOutput
Case 1 'existing workbook
Set xlwkb = xlwkbs(strTarget)
Case 2 'new workbook
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strTarget) Then
fso.DeleteFile (strTarget) 'delete if already exists
End if
xlwkbs.Add '************************
End Select
For Each fldSub In fld.SubFolders
strMdb = fld & "\" & fldSub.Name & "\MEAS.MDB"
If LinkTables(strMdb) Then Call CreateWorksheets(bytOutput, _
strTarget, xlapp, xlwkbs, xlwkb)
Next fldSub
GetSubFolders = True
End Function

Next, I need to insert a bunch of Worksheets. Am I going about this the
right way?

Private Function CreateWorksheets(bytOutput As Byte, strTarget As String, _
xlapp As Excel.Application, xlwkbs As Excel.Workbooks, wkb As
Excel.Workbook)
Dim xlwks As Excel.Worksheets
Dim xlwkss As Excel.Worksheets
Dim i As Byte
Select Case bytOutput
Case 1 'existing workbook
i = xlwkbs.Count - 1
xlwkss.Add After:=Worksheets(i)
Case 2 'new workbook
xlwkss.Add After:=Worksheets(i)
End Select
Set xlwks = xlwkss(i + 1)
xlwks.Name = strWksName '************
Call PopulateWorksheet 'dumps tables into wks
End Function

Thanks in advance.

 

[Bob Phillips]

Deko,

You cannot rename the workbook as you add it, it doesn't get a name until it
is saved, so you should save it after creating to give it a name.

To add a worksheet and name it, use

worksheets.Add(After:=worksheets(i)).name=strWksName

--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[deko]

You cannot rename the workbook as you add it, it doesn't get a name until
it

is saved, so you should save it after creating to give it a name.

Ah, I see....

Here's what I've got so far:

Dim NewWorkbook as Object

Case 1 'existing workbook
Set xlwkb = xlwkbs(strTarget)
Case 2 'new workbook
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strTarget) Then fso.DeleteFile (strTarget)
Set NewWorkbook = xlwkbs.Add
NewWorkbook.SaveAs (strTarget)


Seems to be working - but is it possible to create the Workbook without any
Worksheets? I will be adding several with code, and they need to be named
as thery are added. I suppose I could just delete the default 3 sheets, but
it would be more efficient to create the Workbook without any sheets. Can
this be done?

To add a worksheet and name it, use

worksheets.Add(After:=worksheets(i)).name=strWksName

Great! That looks easy enough.

Thanks for the help!

 

[Bob Phillips]

You cannot create a workbook with no worksheets, must be at least 1. You can
pre-set this like so

Application.SheetsInNewWorkbook = 1
Workbooks.Add



--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[deko]

You cannot create a workbook with no worksheets, must be at least 1. You
can

pre-set this like so

Application.SheetsInNewWorkbook = 1
Workbooks.Add

10-4.

Could you also help me with the following question:

I am using late binding, and need to pass objects between functions. How do
I do this?

Do I do it like this:

Private Function CreateWorksheet(bytOutput As Byte, strTarget As String, _
xlapp As Object, xlwkbs As Object, _
xlwkb As Object, strSheetName As String)

Dim xlwks As Object
Dim xlwkss As Object
Dim i As Byte
Set xlwkss = xlwkb.Worksheets
Debug.Print xlwkss.Count '**** ? ?
i = xlwkss.Count
xlwkss.Add After:=Worksheets(i).Name = strSheetName
Debug.Print "inserting worksheet " & i

End Function

The idea is to set the objects once in the calling function, and then make a
call to this function from a loop (so I don't have to create and destroy the
objects in each iteration). Doe this make sense?

Thanks again.

 

[Bob Phillips]

Deko,

That is one way of passing objects, but I would make few observations.

Firstly, pass your variables ByVal unless you need to modify them, it is
more efficient.

Private Function CreateWorksheet(ByVal bytOutput As Byte, _
ByVal strTarget
As String, _
ByVal xlapp As
Object, _
ByVal xlwkbs As
Object, _
ByVal xlwkb As
Object, _
ByVal
strSheetName As String)

If you are setting specific objects in the caller, such as the workbook, you
will already have used the app object, so it is probably not necessary to
pass that. It is hard for me to be definitive, as there is no code in the
called module that uses it, so I assume it is just example code. Only pass
the objects that you need.

This statement seems superfluous

Set xlwkss = xlwkb.Worksheets
Debug.Print xlwkss.Count '**** ? ?

why not just use

Debug.Print xlwkb.Worksheets.Count

setting the object seems pointless, even for the worksheet.add.

Oh, I also don't think this works

xlwkss.Add After:=Worksheets(i).Name = strSheetName

it should be

xlwkss.Add(After:=Worksheets(i)).Name = strSheetName


--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[deko]

That is one way of passing objects, but I would make few observations.

Firstly, pass your variables ByVal unless you need to modify them, it is
more efficient.

Private Function CreateWorksheet(ByVal bytOutput As Byte, _
ByVal strTarget
As String, _
ByVal xlapp As
Object, _
ByVal xlwkbs As
Object, _
ByVal xlwkb As
Object, _
ByVal
strSheetName As String)

If you are setting specific objects in the caller, such as the workbook, you
will already have used the app object, so it is probably not necessary to
pass that. It is hard for me to be definitive, as there is no code in the
called module that uses it, so I assume it is just example code. Only pass
the objects that you need.

This statement seems superfluous

Set xlwkss = xlwkb.Worksheets
Debug.Print xlwkss.Count '**** ? ?

why not just use

Debug.Print xlwkb.Worksheets.Count

setting the object seems pointless, even for the worksheet.add.

Oh, I also don't think this works

xlwkss.Add After:=Worksheets(i).Name = strSheetName

it should be

xlwkss.Add(After:=Worksheets(i)).Name = strSheetName

Thanks very much... I may be in over my head here and and appreciate the
help. Here is more complete code. Getting the worksheets into the workbook
is my current sticking point.

The goal is to loop through about 40 subdirectories, each containing one mdb
(all 40 have the same name and structure, just different data), then link to
the mdb's tables and spit out a worksheet for each mdb (simply a dump of a
couple of tables to a worksheet). So, the goal is to create 40 worksheets
(all named the same as the subdirectory)

There are 2 options: insert into a new worksheet, or into an existing
worksheet. The worksheets are defined in strTarget (e.g.
C:\path\to\some.xls)

FUNCTION 1 - creates objects, loops through dir structure

Public Function GetSubFolder(fld As Scripting.Folder) As Boolean
On Error GoTo HandleErr
Dim xlapp As Object
Dim xlwkbs As Object
Dim xlwkb As Object
Dim xlnewwkb As Object
Dim fldSub As Scripting.Folder
Dim fso As Scripting.FileSystemObject
Dim strMdb As String
Dim strSheetName As String
Dim strTarget As String
Dim bytOutput As Byte
Set xlapp = GetObject(, "Excel.Application")
Set xlwkbs = xlapp.Workbooks
bytOutput = Forms("frmMain")!fraOutput
strTarget = Forms("frmMain")!txtOutput
Select Case bytOutput
Case 1 'existing workbook
'Set xlwkb = xlwkbs(strTarget)
Case 2 'new workbook
xlapp.SheetsInNewWorkbook = 1
Set xlnewwkb = xlwkbs.Add
'xlwkb.Close
xlnewwkb.SaveAs (strTarget)
'Set xlwkb = xlwkbs(strTarget)
End Select
For Each fldSub In fld.SubFolders
strSheetName = fldSub.Name
strMdb = fld & "\" & strSheetName & "\MEAS.MDB"
If LinkTable(strMdb) Then
Call CreateWorksheet(bytOutput, strTarget, _
xlapp, xlwkbs, strSheetName)
End If
Next fldSub
GetSubFolder = True
Exit_Here:
On Error Resume Next
xlapp.Quit
Set xlwkb = Nothing
Set xlapp = Nothing
Set fso = Nothing
Exit Function
HandleErr:
Select Case Err.Number
Case 429
Set xlapp = CreateObject("Excel.Application")
Resume Next
Case Else
Debug.Print Err.Number & " " & Err.Description '& vbCrLf &
vbCrLf & _
"modWorksheet.GetSubFolder", vbExclamation, " Unexpected
Error"
End Select
GetSubFolder = False
Resume Exit_Here
End Function

FUNCTION 2 - links tables

Private Function LinkTable(strMdb) As Boolean
On Error GoTo HandleErr
Dim varTdf As Variant
Dim tdf As DAO.TableDef
Dim db As DAO.Database
Set db = CurrentDb
For Each varTdf In Array("Measurement", "MeasurementParameter")
Set tdf = db.CreateTableDef(varTdf)
tdf.Connect = ";DATABASE=" & strMdb
tdf.SourceTableName = varTdf
db.TableDefs.Append tdf
Debug.Print strMdb & " - " & tdf.Name
Next
LinkTable = True
Exit_Here:
Exit Function
HandleErr:
Select Case Err.Number
Case 3012 'Object '[table name]' already exists.
Resume Next
Case Else
MsgBox Err.Description & vbCrLf & vbCrLf & _
"modWorksheet.LinkTable", vbExclamation, " Unexpected Error"
End Select
Resume Exit_Here
End Function

FUNCTION 3 - creates worksheets

Private Function CreateWorksheet(bytOutput As Byte, strTarget As String, _
xlapp As Object, xlwkbs As Object, strSheetName As String)
On Error GoTo HandleErr
Dim xlwks As Object
Dim xlwkss As Object
Dim i As Integer
Set xlwkss = xlwkbs(strTarget).Worksheets
i = xlwkss.Count
xlwkss.Add After:=xlwkss(i).Name = strSheetName
Debug.Print "inserting worksheet " & strSheetName
Exit_Here:
Exit Function
HandleErr:
Select Case Err.Number
Case Else
CreateWorksheet = False
Debug.Print Err.Number & " " & Err.Description '& vbCrLf &
vbCrLf & _
"modWorksheet.CreateWorksheet", vbExclamation, " Unexpected
Error"
End Select
Resume Exit_Here
End Function

 

[deko]

To the OP: you may be over looking something obvious: it is most

efficient to let the Jet provider/driver create the workbooks and
worksheets for you because it works at a much lower level. For example,
consider this:

SELECT CustomerID, CompanyName
INTO [Excel 8.0;Database=C:\MyNewWorkbook.xls;].MyNewRange
FROM [MS Access;Database=C:\Tempo\nwnd4.mdb;].Customers;

If the workbook MyNewWorkbook.xls did not exist in that location, it
would be created automatically and if MyNewRange was not an existing
defined Name it too would be created on a new sheet of the same name
(assuming one did not already exist).

I've noticed this is rather slow:

j = xlapp.Workbooks(strXlsFile).Worksheets.Count
xlapp.Workbooks(strXlsFile).Worksheets.Add(After:=xlapp.Workbooks _
(strXlsFile).Worksheets(j)).Name = (strSheetName & " Data")
n = 1
Set rst = db.OpenRecordset(strSqlRecordset)
Do While Not rst.EOF
For m = 0 To rst.Fields.Count - 1
varCurrentField = rst(m)
xlapp.Workbooks(strXlsFile).Worksheets(j + 1).Cells(n, m + 1).Value
= _
varCurrentField
Next m
rst.MoveNext
n = n + 1
Loop

However, the user wants to be able to insert all these worksheets (40+) into
an existing workbook.

Would something like this work:

j = xlapp.Workbooks(strXlsFile).Worksheets.Count
db.Execute _
SELECT CustomerID, CompanyName
INTO [Excel 8.0;Database=C:\MyNewWorkbook.xls;].Worksheets(j+1)
FROM [MS Access;Database=C:\Tempo\nwnd4.mdb;].Customers;

I didn't realize Jet could create Excel workbooks. Thanks for the tip.

 

[deko]

No, but this would:

db.Execute _
"SELECT CustomerID, CompanyName" & _
" INTO [Excel 8.0;Database=C:\MyNewWorkbook.xls;]" & _
".Sheet" & CStr(j + 1) & _
" FROM [MS Access;Database=C:\Tempo\nwnd4.mdb;].Customers;"

I tried simplifying this and running it as a compiled query like this:

SELECT [Mean] INTO [Excel 8.0;Database=C:\Documents and
Settings\Administrator\Desktop\munch5\Munch1100.xls;] FROM
MeasurementParameter

No luck.

MeasurementParameter is an internal table. I also tried it with quotes
around the path. Still no luck. The error message tells me 'Excel
8.0;Database=C:\...' is not a valid name.

I will keep experimenting. If I can get this to work it will really speed
up my app. Other suggestions welcome!

 

[deko]

You are missing the Excel table name e.g.

SELECT [Mean] INTO [Excel 8.0;Database=C:\Documents and
Settings\Administrator\Desktop\munch5\Munch1100.xls;].Sheet99 FROM
MeasurementParameter

Jamie.

Thanks for pointing me in the right direction. Using the query is *much*
faster than the recordset. However, I noticed that Excel must be closed for
this to work, which means I can't create the charts in the same loop - so I
use 2 loops:

For Each fldSub In fld.SubFolders
strSheetName = fldSub.Name
strMdbPath = fld & "\" & strSheetName & "\MEAS.MDB"
If LinkTable(strMdbPath, strXlsPath, strSheetName) Then
blnNoData = Nz(DMin("ParameterID", "MeasurementParameter"), -1)
If Not blnNoData Then
If GetNewTables Then
k = k + 1
ReDim Preserve sn(1 To k)
sn(k) = strSheetName
db.Execute "qryMean", dbFailOnError
db.Execute "qryDateTime", dbFailOnError
db.Execute "qryExcelData", dbFailOnError
db.Execute "SELECT [MeasurementDate], [MeasurementTime],
[Mean] INTO [Excel 8.0;Database=" & strXlsPath & "].[" & strSheetName & "]
FROM tblExcelData"
DoEvents
Else
Call ErrorSheet
End If
Else
Debug.Print "no data in " & strSheetName
End If
End If
Next fldSub
strXlsFile = Dir(strXlsPath)
Forms("frmMain")!txtStatus = "Creating charts..."
Set xlapp = GetObject(, "Excel.Application")
xlapp.Workbooks.Open (strXlsPath)
For p = LBound(sn) To UBound(sn)

xlapp.Workbooks(strXlsFile).Worksheets(sn(p)).Cells(1).EntireRow.Font.Bold =
True
xlapp.Workbooks(strXlsFile).Worksheets(sn(p)).Range("A1",
"C1").EntireColumn.AutoFit

xlapp.Workbooks(strXlsFile).Charts.Add(Before:=xlapp.Workbooks(strXlsFile).W
orksheets(sn(p))).Name = (sn(p) & "_Chart")
xlapp.Workbooks(strXlsFile).ActiveChart.SetSourceData Source:= _
xlapp.Workbooks(strXlsFile).Worksheets(sn(p)).Range("A1:C" & _

xlapp.Workbooks(strXlsFile).Worksheets(sn(p)).Range("C1").End(xlDown).Row),
_
PlotBy:=xlColumns
xlapp.Workbooks(strXlsFile).ActiveChart.ChartType =
xlLineMarkersStacked
xlapp.Workbooks(strXlsFile).ActiveChart.Axes(xlCategory,
xlPrimary).HasTitle = False
xlapp.Workbooks(strXlsFile).ActiveChart.Axes(xlValue,
xlPrimary).HasTitle = False
xlapp.Workbooks(strXlsFile).ActiveChart.HasLegend = False
xlapp.Workbooks(strXlsFile).ActiveChart.HasTitle = False
DoEvents
Next p
xlapp.Workbooks(strXlsFile).Save
xlapp.Workbooks(strXlsFile).Close
CreateWorksheets = True
Forms("frmMain")!txtStatus = UBound(sn) & " worksheets created"
Exit_Here:
On Error Resume Next
xlapp.Quit
Call CleanUp("Excel.exe")
Set db = Nothing
Set xlapp = Nothing
Set fso = Nothing
Exit Function
End Function