how to fill 2 access columns with workbooknames and worksheetname

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Dear All,

Please any idea on how to insert the filename without the .xls extension in
the first column of the access table and the worksheet name in the second
column of the access table?.

Please I am working on a cost accounting document of
a company. The workbook is named after the cost center name eg Sales and the
Worksheet is named after the general ledger code (GLCode eg EE00875). After
trasfering all worksheets of all workbooks into one access table using the
TransferSpreadsheet method (this is successful), I created two columns using
the RunSQL and ALTER TABLE statement (this als is successful). I want to fill
these two columns with the workbookname without the .xls extension and the
worksheetnames in the access table. This does not work. I am using the INSERT
INTO-- VALUES statement. See the code below.


Private Sub Command7_Click()
Dim xlApp As Excel.Application
Dim xlWS As Excel.Worksheet
Dim xlWB As Excel.Workbook
Dim i As Integer
Dim strFileName As String


Dim wkShName As String
Dim strFolderPath As String
Dim strPath As String
Dim strPathBrowser As String
Dim bookName As String
Dim strFileNameValue As String
Dim strFullPath As String
Dim j As Integer

Set xlApp = New Excel.Application
On Error Resume Next
strPath = "C:\Documents and Settings\a99858\My Documents\"
strFileName = Dir(strPath & "*.xls")

strFullPath = strPath & strFileName
Do While Len(strFileName) > 0


strFullPath = strPath & strFileName
strFileNameValue = strFileName

xlApp.Workbooks.Open (strFullPath)

For j = 1 To xlApp.Worksheets.count
Set xlWS = xlApp.ActiveWorkbook.Worksheets(j)
wkShName = xlWS.Name

DoCmd.TransferSpreadsheet acImport, , "MultiSheet_Example", strFullPath, -1,
wkShName & "!A1:F8"

DoCmd.RunSQL "ALTER TABLE MultiSheet_Example ADD COLUMN CCCode CHAR, GCode
CHAR", -1
DoCmd.RunSQL "INSERT INTO MultiSheet_Example (CCCode ,GCode) VALUES (&
strFileNameValue, & wkShName)"

Next j

strFileName = Dir()
Loop

End Sub


Please any idea on how to insert the workbooknames and corresponding
worksheet names into the columns created?

Thanks
Gokop
 
There were a couple of problems. You have the ALTER TABLE code INSIDE a
For...Next loop, nested INSIDE a Do...Loop. This means that you tried to
alter the table every loop which should have caused an error.

You had the error handling turned off ("On Error Resume Next") so you never
saw the error.

Another problem is missing delimeters in the UPDATE code.


I have A2K and I don't know what version you have so I modified the code to
use Late Binding (I think <g>). It seems that A2k does not release (quit)
Excel when opened by automation. So you might need to close Excel manually.
Anyone know a solution to closing Excel using automation in A2K???

This code worked on my computer, but ........
Watch for line wrap

'---------------------------------------------------------
Private Sub Command7_Click()
On Error GoTo ErrorHandler

'The following is Dimmed when Late Binding is on

Dim objXL As Object
Dim objSht As Object
' Dim objWkb As Object

' Set objXL = New Excel.Application
' Set objXL = CreateObject("Excel.Application")

' The following is Dimmed when a reference is used.

'Dim objXL As Excel.Application
'Dim objWkb As Excel.Workbook
'Dim objSht As Excel.Worksheet

Dim wkShName As String
Dim strSQL As String

Dim strFullPath As String
Dim strPath As String
Dim strFileName As String
Dim strFileNameValue As String

Dim j As Integer

Dim blnExcelAlreadyOpen As Boolean

' Getobject function called without the first argument returns a
' reference to an instance of the application. If the application isn't
' running, an error occurs.
Set objXL = GetObject(, "Excel.Application") ' reference an existing
application instance

If objXL Is Nothing Then ' no existing application is running
Set objXL = CreateObject("Excel.Application") ' create a new
application instance
Let blnExcelAlreadyOpen = False
Else
Let blnExcelAlreadyOpen = True
End If

strPath = "C:\Documents and Settings\a99858\My Documents\"
strFileName = Dir(strPath & "*.xls")

Do While Len(strFileName) > 0

strFullPath = strPath & strFileName

'workbook name minus the extension
strFileNameValue = Left(strFileName, Len(strFileName) - 4)

objXL.Workbooks.Open (strFullPath)
objXL.Visible = True

For j = 1 To objXL.Worksheets.count
Set objSht = objXL.ActiveWorkbook.Worksheets(j)
wkShName = objSht.Name

DoCmd.TransferSpreadsheet acImport, , "MultiSheet_Example",
strFullPath, -1, wkShName & "!A1:F8"

'Don't want to use *ALTER TABLE* INSIDE a loop.
'every time it executes, two more fields would be added to the table
'except that would cause an error - can't have duplicate
' coumn names

' DoCmd.RunSQL "ALTER TABLE MultiSheet_Example ADD COLUMN CCCode
CHAR, GCode CHAR ", -1

' this line has missing delimiters
' DoCmd.RunSQL "INSERT INTO MultiSheet_Example (CCCode ,GCode)
VALUES (& strFileNameValue, & wkShName)"

'create the update SQL string
strSQL = "UPDATE MultiSheet_Example"
strSQL = strSQL & " SET CCCode = '" & strFileNameValue & "', GCode =
'" & wkShName & "'"
strSQL = strSQL & " WHERE CCCode Is Null;"

'update wkbk name and wksht name in table
CurrentDb.Execute strSQL, dbFailOnError


' Debug.Print wkShName
Next j

objXL.ActiveWorkbook.Close savechanges:=False
strFileName = Dir()
Loop

If Not (blnExcelAlreadyOpen) Then
objXL.Visible = True
objXL.Quit
objXL.Application.Quit
End If


Set objSht = Nothing
Set objXL = Nothing

Beep
Beep
Beep

objXL.Visible = True

Exit Sub


ErrorHandler:
If Err.Number = 429 Then 'Excel is not already open, this is okay
Err.Clear
Resume Next
ElseIf Err.Number = -2147417848 Or Err.Number = 424 Then 'Closed Excel
instead of clicking transfer button
Err.Clear
Else
MsgBox "An unexpected error occurred." & vbCrLf & _
"Please note the error, and the circumstances, and inform the
Database Programmer" _
& vbCrLf & "Error #" & Err.Number & " : " & Err.Description,
vbCritical, _
"Unexepcted Error"
End If
End Sub

'---------------------------------------------------------


HTH
 
Dear Steve,

Thanks a lot for your time to debug and make necessary adjustments in the
code. I am using A2K also. I am trying to run the code you sent, will let you
know. Cheers.

Regards
Gokop
 
Dear Steve,

Thanks again. The code does not seem to add the two columns so that they can
be populated with the workbook names and worksheet names respectively. Is
there any reason. I am also using A2K.

Kind regards
Gokop
 
Sorry, I forgot one little bit of info......you have to add the two fields to
the table "MultiSheet_Example".


Method 1: open the table in design mode and add the fields CCCode & GCode
with the datatype of "Text".


Method 2: add a new procedure to a standard module:

'----------------
Sub AddFields()

'should be one line
DoCmd.RunSQL "ALTER TABLE MultiSheet_Example ADD COLUMN CCCode CHAR,
GCode CHAR", -1

End Sub
'----------------


Put the cursor on the SUB line and press the F5 key. DO THIS ONLY ONCE.
You can delete the procedure "Sub AddFields()".

Open the table and check that the two fields have been added.
Now try adding the code that added the workbook/worksheet names.
 
Back
Top