Talking to Excel

  • Thread starter Thread starter Bre-x
  • Start date Start date
B

Bre-x

I would like to transfer the following Excel sub (it works, already test it)
to MS Access. Could you please help me?

Thanks to All

Bre-x

Sub CombineWorkbooks()
Dim bfirst As Boolean, sPath As String
Dim sName As String, bk As Workbook
Dim bk1 As Workbook, sh As Object
bfirst = True
sPath = "N:\1CNCACCESSAPPS\AccessApps\exceltemp\john\"
sName = Dir(sPath & "*.xls")

Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)
Debug.Print bk.Name
If bfirst Then
bk.Sheets.Copy
bfirst = False
Set bk1 = ActiveWorkbook
Else
bk.Sheets.Copy After:=bk1.Sheets(bk1.Sheets.Count)
End If
bk.Close SaveChanges:=False
sName = Dir()
Loop

Application.DisplayAlerts = False
For Each sh In bk1.Sheets
If InStr(1, sh.Name, "summary", vbTextCompare) Or _
InStr(1, sh.Name, "tic&tie", vbTextCompare) Then
sh.Delete
End If
Next
Application.DisplayAlerts = True
End Sub

My Function on MS Access
----------------------------------------------------

Public Function copy_sheets(tcid As Double, tlid As Double, custid As
String, mach As Integer, prog As Integer)
'Dim string Variables
Dim thepath, bfirst As Boolean, sPath As String, sName As String
Dim bk As Workbook
Dim bk1 As Workbook
Dim sh As Object


'Set Variables
thepath = mypath & mach & "\" & custid & "\" & mach & prog & ".xls"

'Set bk = CreateObject("Excel.Application")
'Set bk1 = CreateObject("Excel.Application")

bfirst = True
sPath = "N:\1CNCACCESSAPPS\AccessApps\exceltemp\john\"
sName = Dir(sPath & "*.xls")

Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)
Debug.Print bk.Name
If bfirst Then
bk.Sheets.Copy
bfirst = False
Set bk1 = ActiveWorkbook
Else
bk.Sheets.Copy After:=bk1.Sheets(bk1.Sheets.Count)
End If
bk.Close SaveChanges:=False
sName = Dir()
Loop

With bk1.Application
..Visible = True
..DisplayAlerts = False
For Each sh In .Sheets
If InStr(1, sh.Name, "summary", vbTextCompare) Or _
InStr(1, sh.Name, "tic&tie", vbTextCompare) Then
sh.Delete
End If
Next
.DisplayAlerts = True
End With
End Function
 
I would like to transfer the following Excel sub (it works, already test it)
to MS Access. Could you please help me?
Click to expand...

Since Access doesn't have workbooks or sheets, and since it is a relational
database application rather than a spreadsheet (and thereby requires different
logic), it would really be much easier to rebuild it from scratch. For one
thing you would not loop through rows searching for names, you'ld use a Query.

What is this code intended to *ACCOMPLISH*?
 
Sorry, I didn't explain my self very well.

We have a MS Access database that keeps track of hundred of thousands "CNC
Program Records".
Each record has a Mach ID and Program ID, Work Center ID, and a list of
Mastercam Tools.

Each record is send to an Excel Sheet where notes, pictures and diagrams are
add it. Then printed and give to the Machine Operator.

Each Excel Sheet is fully link and control on MS Access.

We have been using this system since 2002 and works very well for us.

I was ask if we can conbine several Excel sheets into one single Workbook,
and I would like to do it from ms access.

Thank you once again

Bre-x
 
I was ask if we can conbine several Excel sheets into one single Workbook,
and I would like to do it from ms access.
Click to expand...

Sorry... I did misinterpret.

You'll need to use Excel automation, a subject in which I am NOT at all well
versed. If you do that you can run your Excel macro natively in Excel, and not
need to rewrite it at all. I'll bring up this thread to the other MVP's and
see if someone more knowledgable can help!
 
I can't test it, but this looks about right.

BTW, myPath is not defined so will be null.

Public Function copy_sheets(tcid As Double, _
tlid As Double, _
custid As String, _
mach As Long, _
prog As Long)
'Dim string Variables
Dim thepath, bfirst As Boolean, sPath As String, sName As String
Dim xlApp As Object
Dim bk As Object
Dim bk1 As Object
Dim sh As Object

'Set Variables
thepath = mypath & mach & "\" & custid & "\" & mach & prog & ".xls"

Set xlApp = CreateObject("Excel.Application")
With xlApp

.Visible = True
.DisplayAlerts = False
End With

bfirst = True
sPath = "N:\1CNCACCESSAPPS\AccessApps\exceltemp\john\"
sName = Dir(sPath & "*.xls")

Do While sName <> ""

Set bk = Workbooks.Open(sPath & sName)
Debug.Print bk.Name
If bfirst Then

bk.Sheets.Copy
bfirst = False
Set bk1 = ActiveWorkbook
Else

bk.Sheets.Copy After:=bk1.Sheets(bk1.Sheets.Count)
End If

bk.Close SaveChanges:=False
sName = Dir()
Loop

With bk1

For Each sh In .Worksheets

If InStr(1, sh.Name, "summary", vbTextCompare) Or _
InStr(1, sh.Name, "tic&tie", vbTextCompare) Then

sh.Delete
End If
Next
End With

xlApp.DisplayAlerts = True
Set xlApp = Nothing
xlApp.Quit
End Function
 
Hi Bre-x,

I am assuming that your final goal is to combine all the data from each
sheet into one table in Access... if this is the case...

you have 2 options:
1. make a table in Access with the desired structure
2. look at each sheet to make sure it has what you are looking for and,
if so, transfer the data on the sheet to the table
OR
1. import each worksheet that has what you are looking for as a separate
table in Access, then write additional code to combine them

I did not finish the code because I do not know which option you want,
nor do I know what to look for in the Excel sheet to make sure it has
what you are looking for ... but here is some 'shell' code:

'~~~~~~~~~~~~~~~~~~~~~~~~~~
Function TransferExcelSheetsToTable()
'currently, this only counts
' it loops through Excel files in a specified directory
' opens each workbook, and counts the sheets


'Crystal
'strive4peace2006 at yahoo dot com

On Error GoTo Proc_Err

TransferExcelSheetsToTable = False

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~comment one of these blocks

'--- early binding -- use to develop
Dim xlApp As Excel.Application _
, xlWb As Excel.workbook _
, xlWs As Excel.Worksheet

' '--- late binding -- use to deploy
' Dim xlApp As Excel.Application _
' , xlWb As Excel.workbook _
' , xlSh As Excel.Worksheet
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Dim booLeaveOpen As Boolean _
, arrFile() As String _
, i As Integer _
, mNumSheets As Integer _
, mNumSheetsTotal As Integer _
, mNumFiles As Integer _
, mPath As String

mPath = "N:\1CNCACCESSAPPS\AccessApps\exceltemp\john\"

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Load filenames into an array
i = 1
ReDim arrFile(1)
arrFile(1) = Dir(mPath & "*.xls")

Do While arrFile(i) <> ""
If (GetAttr(mPath & "\" & arrFile(i)) _
And vbDirectory) <> vbDirectory Then
i = i + 1
ReDim Preserve arrFile(i)
arrFile(i) = Dir()
End If
Loop

'remove last entry which is blank
If i > 1 Then ReDim Preserve arrFile(i - 1)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

If Not UBound(arrFile) > 0 Then
MsgBox "There are no files to read for " _
& mPath _
, , "No Files"""
GoTo Proc_Exit
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

'if Excel is already open, use that instance
booLeaveOpen = True

'attempting to use something that is not available
'will generate an error
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo Proc_Err

'If xlApp is defined, then we
'already have a conversation
If TypeName(xlApp) = "Nothing" Then
booLeaveOpen = False
'Excel was not open -- create a new instance
Set xlApp = CreateObject("Excel.Application")
End If

mNumFiles = 0
mNumSheetsTotal = 0

For i = 1 To UBound(arrFile)

Debug.Print arrFile(i);

'don't update links, open as read-0nly
Set xlWb = xlApp.Workbooks.Open( _
mPath & arrFile(i), False, True)

mNumFiles = mNumFiles + 1

mNumSheets = 0

If xlWb.Worksheets.Count = 0 Then
GoTo NextWorkbook
End If

For Each xlWs In xlWb.Worksheets

' set up a table in Access
' and compare the structure of sheet to make sure it is right
' then transfer the data
' or
' import all the sheets as separate tables and then do stuff

'all this does right now is count ...

mNumSheets = mNumSheets + 1
Next xlWs

Debug.Print " --" & i & " worksheets"
mNumSheetsTotal = mNumSheetsTotal _
+ mNumSheets

NextWorkbook:

xlWb.Close False
Next i

MsgBox "Transferred data from " _
& mNumSheetsTotal & " worksheets" _
& " in " & mNumFiles & " Files" _
, , "Done"

TransferExcelSheetsToTable = True

Proc_Exit:
On Error Resume Next
Set xlWs = Nothing
If Not xlWb Is Nothing Then
xlWb.Close False
Set xlWb = Nothing
End If

If TypeName(xlApp) <> "Nothing" Then
xlApp.ActiveWorkbook.Close False
If Not booLeaveOpen Then xlApp.Quit
Set xlApp = Nothing
End If

Exit Function

Proc_Err:
MsgBox Err.Description, , _
"ERROR " & Err.Number _
& " TransferExcelSheetsToTable "

Resume Proc_Exit
'if you want to single-step code to find error, CTRL-Break at MsgBox
'then set this to be the next statement
Resume
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~




Warm Regards,
Crystal
remote programming and training

Video Tutorials on YouTube!
http://www.youtube.com/user/LearnAccessByCrystal

Access Basics
8-part free tutorial that covers essentials in Access
http://www.AccessMVP.com/strive4peace

*
(: have an awesome day :)
*
 
Hi Crystal,
I am assuming that your final goal is to combine all the data from each
sheet into one table in Access...
Click to expand...

My interpretation is that Bre-x wants to combine all the data from each
sheet, in several Excel files, into one workbook in Excel using VBA code
within an Access application. His/her function likely references values in a
table, such as "tcid", "tlid", "custid", "mach" and "prog".

Bre-x:

As Bob Phillips points out, "myPath is not defined so will be null". I've
put together a test subroutine, along with a revised function that sets
mypath. You should immediately change an option in the Visual Basic Editor
(VBE) to Require Variable Declaration, as mypath was initially an undeclared
variable. See this article for more discussion:

Always Use Option Explicit
http://www.access.qbuilt.com/html/gem_tips.html#VBEOptions

Here is a start, although you've got more work to do. I was able to get this
function to combine worksheets from source Excel files, into one file, and
delete the appropriate sheets ("summary" and "tic&tie"). Your code, as
written, skips the first Excel file found by the DIR function. I'm not sure
if that is what you intended or not.

Sub TestIT()

Call copy_sheets(1, 1, "123", 2, 2)

End Sub

Public Function copy_sheets( _
tcid As Double, _
tlid As Double, _
custid As String, _
mach As Integer, _
prog As Integer)

Dim thepath As String
Dim sPath As String
Dim bfirst As Boolean
Dim sName As String
Dim bk As Workbook
Dim bk1 As Workbook
Dim sh As Object
Dim mypath As String


'Set Variables
mypath = "G:\Temp\Combined\"
thepath = mypath & mach & "\" & custid & "\" & mach & prog & ".xls"

Set bk1 = Workbooks.Open(thepath)

bfirst = True
sPath = "N:\1CNCACCESSAPPS\AccessApps\exceltemp\john\"
sPath = "G:\Temp\"
sName = Dir(sPath & "*.xls")

Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)
Debug.Print bk.Name

If bfirst Then
bk.Sheets.Copy
bfirst = False
Set bk = ActiveWorkbook
Else
bk.Sheets.Copy After:=bk1.Sheets(bk1.Sheets.Count)
End If
bk.Close SaveChanges:=False
sName = Dir()
Loop

With bk1.Application
.Visible = True
.DisplayAlerts = False
For Each sh In .Sheets
If InStr(1, sh.Name, "summary", vbTextCompare) Or _
InStr(1, sh.Name, "tic&tie", vbTextCompare) Then
sh.Delete
End If
Next sh
.DisplayAlerts = True
End With

End Function


When testing, make sure to periodically open up Task Manager
(Ctrl-Alt-Delete) and End Process on copies of Excel that should not be
running. That's the part that I was alluding to above, when I said that you
have more work to do.


Tom Wickerath
Microsoft Access MVP
http://www.accessmvp.com/TWickerath/
http://www.access.qbuilt.com/html/expert_contributors.html
 
Hello!
Set bk = Workbooks.Open(sPath & sName)
Click to expand...

That doesn't work in Access, you need a qualified Excel Application, e.g.,
xlVariable.Workbooks.Etc... I.e., you're actually hanging Excel in memory.

You can't use ActiveWorkbook, either. xlApp.Workbooks(1) works.

Workbooks don't have Applications. While they might, they shouldn't, they
have Worksheets. They also have a Parent, the Application. Just use the
Application Variable, it controls both Workbooks, you're only using one
Application Instance.
 
Yes, sir. Works (or not so much) every time. You think it works once, not so
much after that!

It's kind of bad behavior on VBA's part, it looks like it works, but under
the hood, not working that well. It sets a General reference to an
unidentifiable instance of Excel, and can't resolve it, should you try your
madness, again.
 
Hi Tom,

I know he said what he wanted to do was combine the sheets into one
workbook -- but he also said data was in Access, so I am assuming
(perhaps incorrectly) that it is normalized and all in one place... so I
was giving him a way to consolidate everything in all the worksheets

~~~
you are incorrect, it does not skip the first file, it simply does not
assign anything to index = 0 if the array index starts there...the first
file is index used is 1 -- that is why I used
For i = 1 To UBound(arrFile)
instead of
For i = LBound(arrFile) To UBound(arrFile)

I did it this way because I like to use
Option Base 1
(Used at module level to declare the default lower bound for array
subscripts)
-- so the code works with both Base 0 or Base 1

.... but there is an error ... statement should read:
If Not UBound(arrFile) > 1 Then
not >0
when testing to see if any Excel files were found
~~~

I would have explained more, but I had hungry boys who wanted to get
food before the store closed <smile>

~~~
The reason I read filenames into an array instead of just looping and
getting them with DIR is in case TransferSpreadsheet would be used ...
that can reset the Dir loop -- also, if the code breaks, then the Dir
loop will lose its place. For these reasons, I have found it best to
load filenames into an array, then work with the array.

~~~

NOTE (Bre-x):
the IDs should be dimensioned as LONG in the parameters, not double
(since double is stored as a floating point number and not accurate for
exact comparisons). I am assuming these are either Autonumber or Long
in Access -- if not, then they should be


Warm Regards,
Crystal
remote programming and training

Video Tutorials on YouTube!
http://www.youtube.com/user/LearnAccessByCrystal

Access Basics
8-part free tutorial that covers essentials in Access
http://www.AccessMVP.com/strive4peace

*
(: have an awesome day :)
*
 
Hi Crystal,
you are incorrect, it does not skip the first file, it simply does not
assign anything to index = 0 if the array index starts there...
Click to expand...

I was not commenting on your code--in fact, I did not even look at it. My
comment about skipping the first Excel file (ie. the worksheets in this file
are not added to the combined Excel file) was applicable only to the code
that Bre-x presented in the orginal post, which does not involve an array. I
tested it, and that's the result I got.



Tom Wickerath
Microsoft Access MVP
http://www.accessmvp.com/TWickerath/
http://www.access.qbuilt.com/html/expert_contributors.html
__________________________________________
 
My 2 cents

I don't know which is faster but you are copying all the sheets into the bk1
and then deleting - probably what will be many worksheets from the new book.
- some change to the code below.

Bob Phillips said:
I can't test it, but this looks about right.

BTW, myPath is not defined so will be null.

Public Function copy_sheets(tcid As Double, _
tlid As Double, _
custid As String, _
mach As Long, _
prog As Long)
'Dim string Variables
Dim thepath, bfirst As Boolean, sPath As String, sName As String
Dim xlApp As Object
Dim bk As Object
Dim bk1 As Object
Dim sh As Object
Click to expand...
Dim intSheetCount as Integer
Dim intLoop as Integer
'Set Variables
thepath = mypath & mach & "\" & custid & "\" & mach & prog & ".xls"

Set xlApp = CreateObject("Excel.Application")
With xlApp

.Visible = True
.DisplayAlerts = False
Click to expand...
'Create the bk1 with 1 sheet
.Workbooks.Add(xlWBATWorksheet)
intSheetCount = 1
End With

bfirst = True
sPath = "N:\1CNCACCESSAPPS\AccessApps\exceltemp\john\"
sName = Dir(sPath & "*.xls")

Do While sName <> ""

Set bk = Workbooks.Open(sPath & sName)
Debug.Print bk.Name
Click to expand...

For intLoop = 0 to bk.Sheets.Count -1

If InStr(1, bk.Shetes(intLoop).Name, "summary", vbTextCompare)
Or _
InStr(1, bk.Shetes(intLoop).Name, "tic&tie", vbTextCompare)
Then
' don't copy
Else
bk.Sheets(intLoop).Copy After:=bk1.Sheets(intSheetCount-1)
intSheetCount = IntSheetCount +1
Endif
next intLoop
' don't Need >
If bfirst Then

bk.Sheets.Copy
bfirst = False
Set bk1 = ActiveWorkbook
Else

bk.Sheets.Copy After:=bk1.Sheets(bk1.Sheets.Count)
End If
Click to expand...

'don't need <
bk.Close SaveChanges:=False
sName = Dir()
Loop
Click to expand...
bk1.Sheets(0).delete
'dont need >
With bk1

For Each sh In .Worksheets

If InStr(1, sh.Name, "summary", vbTextCompare) Or _
InStr(1, sh.Name, "tic&tie", vbTextCompare) Then

sh.Delete
End If
Next
End With
Click to expand...
' don't need <
 
I would like to thank you all of you for your time. I would be testing all
your suggestions.

A couple of thinks to clarify

"mypath" is a Public Const (mypath = "N:\1CNCACCESSAPPS\UMW\")

There are jobs that requiere more than one machine and/or operator. That is
way the need to combine more than one CNC Program Record's Excel Sheet. (as
a termpory measure, the db records stay as they are)

Once again thank you all!!!!!

Bre-x
 
Bre-x said:
I would like to transfer the following Excel sub (it works, already test
it) to MS Access. Could you please help me?

Thanks to All

Bre-x

Sub CombineWorkbooks()
Dim bfirst As Boolean, sPath As String
Dim sName As String, bk As Workbook
Dim bk1 As Workbook, sh As Object
bfirst = True
sPath = "N:\1CNCACCESSAPPS\AccessApps\exceltemp\john\"
sName = Dir(sPath & "*.xls")

Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)
Debug.Print bk.Name
If bfirst Then
bk.Sheets.Copy
bfirst = False
Set bk1 = ActiveWorkbook
Else
bk.Sheets.Copy After:=bk1.Sheets(bk1.Sheets.Count)
End If
bk.Close SaveChanges:=False
sName = Dir()
Loop

Application.DisplayAlerts = False
For Each sh In bk1.Sheets
If InStr(1, sh.Name, "summary", vbTextCompare) Or _
InStr(1, sh.Name, "tic&tie", vbTextCompare) Then
sh.Delete
End If
Next
Application.DisplayAlerts = True
End Sub

My Function on MS Access
----------------------------------------------------

Public Function copy_sheets(tcid As Double, tlid As Double, custid As
String, mach As Integer, prog As Integer)
'Dim string Variables
Dim thepath, bfirst As Boolean, sPath As String, sName As String
Dim bk As Workbook
Dim bk1 As Workbook
Dim sh As Object


'Set Variables
thepath = mypath & mach & "\" & custid & "\" & mach & prog & ".xls"

'Set bk = CreateObject("Excel.Application")
'Set bk1 = CreateObject("Excel.Application")

bfirst = True
sPath = "N:\1CNCACCESSAPPS\AccessApps\exceltemp\john\"
sName = Dir(sPath & "*.xls")

Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)
Debug.Print bk.Name
If bfirst Then
bk.Sheets.Copy
bfirst = False
Set bk1 = ActiveWorkbook
Else
bk.Sheets.Copy After:=bk1.Sheets(bk1.Sheets.Count)
End If
bk.Close SaveChanges:=False
sName = Dir()
Loop

With bk1.Application
.Visible = True
.DisplayAlerts = False
For Each sh In .Sheets
If InStr(1, sh.Name, "summary", vbTextCompare) Or _
InStr(1, sh.Name, "tic&tie", vbTextCompare) Then
sh.Delete
End If
Next
.DisplayAlerts = True
End With
End Function
Click to expand...
 
Finally after many hours and with the help of lots of people. Thank you all.

MS Access Function
---------------------

Public Function copy_sheets(tcid As Double, tlid As Double, custid As
String, mach As Integer, prog As Integer)
'Dim String Variables
Dim thepath As String, mytemp As String

'Dim Excel Object
Dim objXL As Object
Dim objWB As Object


'Set Variables
thepath = mypath & mach & "\" & custid & "\" & mach & prog & ".xls"
mytemp = exceltemp & VBA.Environ("USERNAME") & "\" & mach & prog & ".xbk"
basname = "N:\1CNCACCESSAPPS\AccessApps\lathe\vba_excel.bas"

'Make a Backup
Responce = copy_file(thepath, mytemp)

'OPEN EXCEL
Set objXL = CreateObject("Excel.Application")
With objXL.Application
.Visible = False
.Workbooks.Open lathe_transf

Set objSht = objXL.Worksheets("Lathe")
With objSht
objSht.Cells(1, 1).Value = exceltemp &
VBA.Environ("USERNAME") & "\"
objSht.Cells(2, 1).Value = thepath
End With
'THIS MACRO WILL COPY ALL SHEETS ON .xbk to book1, PLUS COPY A MODULE
.Run "CombineWorkbooks"
.Quit
End With

End Function

EXCEL VBA Code
-----------------------------

Sub CombineWorkbooks()
Dim bfirst As Boolean, sPath As String
Dim sName As String, bk As Workbook
Dim bk1 As Workbook, sh As Object
bfirst = True
sPath = Sheets("Lathe").Range("A1").Value
thdest = Worksheets(1).Range("A2").Value


sName = Dir(sPath & "*.xbk")

Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)
Debug.Print bk.Name
If bfirst Then
bk.Sheets.Copy
bfirst = False
Set bk1 = ActiveWorkbook
Else
bk.Sheets.Copy After:=bk1.Sheets(bk1.Sheets.Count)
End If
bk.Close SaveChanges:=False
sName = Dir()
Loop

Application.DisplayAlerts = False
For Each sh In bk1.Sheets
If InStr(1, sh.Name, "summary", vbTextCompare) Or _
InStr(1, sh.Name, "tic&tie", vbTextCompare) Then
sh.Delete
End If
Next
Application.DisplayAlerts = True

Application.DisplayAlerts = False
Windows("Book1").Activate

ActiveWorkbook.VBProject.VBComponents.Import
("N:\1CNCACCESSAPPS\AccessApps\lathe\vba_excel.bas")

ActiveWorkbook.SaveAs Filename:=thdest, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False

ActiveWorkbook.Close
Application.DisplayAlerts = True
ActiveWorkbook.Save
End Sub
 
Back
Top