Shamil Salakhetdinov
shamil at users.mns.ru
Wed May 9 10:15:49 CDT 2007
Hi Mark,
Here is the code to call from MS Access, which shouldn't fail (watch line
wraps!):
Option Explicit
Public Sub TestXLMerge()
Dim strPathName As String
Dim strReport As String
Dim xlApp As Object 'Excel.Application
strPathName = AppPath & "test01.xls"
strReport = "rptInvSummary"
Access.Application.DoCmd.OutputTo acOutputReport, strReport,
acFormatXLS, strPathName
strPathName = AppPath & "test02.xls"
strReport = "rptInvNewSummary"
Access.Application.DoCmd.OutputTo acOutputReport, strReport,
acFormatXLS, strPathName
Set xlApp = CreateObject("Excel.Application")
MergeWorkbooks xlApp, "MergedBooks.xls", AppPath, "test01.xls",
"test02.xls"
xlApp.Quit
Set xlApp = Nothing
End Sub
Public Function MergeWorkbooks( _
ByRef rxlApp As Object, _
ByVal vstrSummaryWbkFileName As String, _
ByVal vstrFolder As String, _
ParamArray avar() As Variant) As Boolean
' This function merges *FIRST* worksheet of every
' workbook, which filename is specified in
' avar() ParamArray and which are located in
' vstrFolder folder.
' Merged workbook is saved into the folder of the
' source workbooks vstrFolder and this merged
' workbook gets the filename vstrSummaryWbkFileName
On Error GoTo HandleErr
Dim wbk As Object 'Excel.Workbook
Dim wbkImp As Object 'Excel.Workbook
Dim impWbkFullPath As String
Dim mergeWbkFullPath As String
Dim evar As Variant
Dim i As Integer
' Check that source workbooks list is not empty
If UBound(avar) = -1 Then
Err.Raise vbObjectError + 1, "MergeWorkbooks", _
"The list of workbooks to merge is empty."
End If
' If absent add backslash to folder name
If Len(vstrFolder) > 0 Then
If Right(vstrFolder, 1) <> "\" Then _
vstrFolder = vstrFolder & "\"
End If
' Create new workbook
Set wbk = rxlApp.Workbooks.Add
' Delete all but the first worksheet in this new workbook
For i = wbk.worksheets.Count To 2 Step -1
rxlApp.DisplayAlerts = False
wbk.worksheets(i).Delete
rxlApp.DisplayAlerts = True
Next i
i = 1
' Merge source workbooks into summary workbook
For Each evar In avar
impWbkFullPath = vstrFolder & CStr(evar)
Set wbkImp = rxlApp.Workbooks.Open(impWbkFullPath)
wbkImp.worksheets(1).Cells.Copy
If wbk.worksheets.Count < i Then _
wbk.worksheets.Add After:=wbk.worksheets(i - 1)
wbk.worksheets(i).Activate
wbk.worksheets(i).Paste
wbk.worksheets(i).Cells(1, 1).Select
wbk.worksheets(i).Name = getUniqueName(wbkImp, 1, wbk)
rxlApp.DisplayAlerts = False
wbkImp.Close
rxlApp.DisplayAlerts = True
i = i + 1
Next evar
wbk.worksheets(1).Activate
mergeWbkFullPath = vstrFolder & vstrSummaryWbkFileName
' Delete merged workbook if it already exists
If Len(Dir(mergeWbkFullPath, vbNormal)) Then _
Kill mergeWbkFullPath
' Save merged workbook
wbk.SaveAs mergeWbkFullPath
' Close workbook
wbk.Close SaveChanges:=False
Set wbk = Nothing
MergeWorkbooks = True
HandleExit:
Exit Function
HandleErr:
MergeWorkbooks = False
MsgBox "MergeWorkbooks: Err = " & Err.Number & " - " & Err.Description
Resume HandleExit
Resume
End Function
Private Property Get AppPath() As String
AppPath = Access.Application.CurrentProject.Path & "\"
End Property
Private Function getUniqueName( _
ByRef rwbkImp As Object, _
ByVal impWbkWksIndex As Integer, _
ByVal rwbkDst As Object) _
As String
On Error Resume Next
Dim strWksName As String
Dim wks As Object
Dim i As Integer
strWksName = rwbkImp.worksheets(impWbkWksIndex).Name
Set wks = rwbkDst.worksheets(strWksName)
If wks Is Nothing Then
getUniqueName = strWksName
Exit Function
End If
i = 1
Do
Set wks = rwbkDst.worksheets(strWksName & "_" & CStr(i))
Loop Until Not wks Is Null
getUniqueName = strWksName & "_" & CStr(i)
End Function
--
Shamil
-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Mark A Matte
Sent: Wednesday, May 09, 2007 6:37 PM
To: accessd at databaseadvisors.com
Subject: Re: [AccessD] Report to Excel_
Thanks Shamil,
The sample call failed...because variable not defined"xlApp". Do I Dim it
as excel.application?
Thanks,
Mark A. Matte
P.S...They are using office97.
>From: "Shamil Salakhetdinov" <shamil at users.mns.ru>
>Reply-To: Access Developers discussion and problem
>solving<accessd at databaseadvisors.com>
>To: "'Access Developers discussion and problem
>solving'"<accessd at databaseadvisors.com>
>Subject: Re: [AccessD] Report to Excel_
>Date: Wed, 9 May 2007 12:24:15 +0400
>
>Hello Mark,
>
>Below is the first version of function to merge workbooks (watch line
>wraps!).
>
>Enhancements to this code might follow today/tomorrow...
>
>Sample call:
>============
>MergeWorkbooks xlApp, "MergedBooks.xls", "C:\Temp", "one.xls", "two.xls"
>
>Code:
>=====
>
>Public Function MergeWorkbooks( _
> ByRef rxlApp As Object, _
> ByVal vstrSummaryWbkFileName As String, _
> ByVal vstrFolder As String, _
> ParamArray avar() As Variant) As Boolean
>' This function merges *FIRST* worksheet of every
>' workbook, which filename is specified in
>' avar() ParamArray and which are located in
>' vstrFolder folder.
>' Merged workbook is saved into the folder of the
>' source workbooks vstrFolder and this merged
>' workbook gets the filename vstrSummaryWbkFileName
>On Error GoTo HandleErr
>Dim wbk As Excel.Workbook
>Dim wbkImp As Excel.Workbook
>Dim impWbkFullPath As String
>Dim mergeWbkFullPath As String
>Dim evar As Variant
>Dim i As Integer
> ' Check that source workbooks list is not empty
> If UBound(avar) = -1 Then
> Err.Raise vbObjectError + 1, "MergeWorkbooks", _
> "The list of workbooks to merge is empty."
> End If
> ' If absent add backslash to folder name
> If Len(vstrFolder) > 0 Then
> If Right(vstrFolder, 1) <> "\" Then _
> vstrFolder = vstrFolder & "\"
> End If
> ' Create new workbook
> Set wbk = rxlApp.Workbooks.Add
> ' Delete all but the first worksheet in this new workbook
> For i = wbk.Worksheets.Count To 2 Step -1
> rxlApp.DisplayAlerts = False
> wbk.Worksheets(i).Delete
> rxlApp.DisplayAlerts = True
> Next i
> i = 1
> ' Merge source workbooks into summary workbook
> For Each evar In avar
> impWbkFullPath = vstrFolder & CStr(evar)
> Set wbkImp = rxlApp.Workbooks.Open(impWbkFullPath)
> wbkImp.Worksheets(1).Cells.Copy
> If wbk.Worksheets.Count < i Then _
> wbk.Worksheets.Add After:=wbk.Worksheets(i - 1)
> wbk.Worksheets(i).Activate
> wbk.Worksheets(i).Paste
> wbk.Worksheets(i).Cells(1, 1).Select
> rxlApp.DisplayAlerts = False
> wbkImp.Close
> rxlApp.DisplayAlerts = True
> i = i + 1
> Next evar
> wbk.Worksheets(1).Activate
>
> mergeWbkFullPath = vstrFolder & vstrSummaryWbkFileName
> ' Delete merged workbook if it already exists
> If Len(Dir(mergeWbkFullPath, vbNormal)) Then _
> Kill mergeWbkFullPath
> ' Save merged workbook
> wbk.SaveAs mergeWbkFullPath
>
> MergeWorkbooks = True
>HandleExit:
> Exit Function
>HandleErr:
> MergeWorkbooks = False
> MsgBox "MergeWorkbooks: Err = " & Err.Number & " - " & Err.Description
> Resume HandleExit
>End Function
>
>
>--
>Shamil
>
>
>-----Original Message-----
>From: accessd-bounces at databaseadvisors.com
>[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Mark A Matte
>Sent: Wednesday, May 09, 2007 12:53 AM
>To: accessd at databaseadvisors.com
>Subject: Re: [AccessD] Report to Excel_
>
>Thanks Michael,
>
>I actually got the formatting like I needed. I'm just having issues
>getting
>
>the worksheets into 1 workbook.
>
>Thanks,
>
>Mark A. Matte
>
>
> >From: "Michael R Mattys" <mmattys at rochester.rr.com>
> >Reply-To: Access Developers discussion and problem
> >solving<accessd at databaseadvisors.com>
> >To: "Access Developers discussion and problem
> >solving"<accessd at databaseadvisors.com>
> >Subject: Re: [AccessD] Report to Excel_
> >Date: Tue, 8 May 2007 13:58:26 -0400
> >
> >Mark,
> >
> >You could put most of your formatting in an xlt, but it's going
> >to take a bit of fancy automation to replicate your report.
> >
> >Michael R. Mattys
> >MapPoint & Access Dev
> >www.mattysconsulting.com
> >
> >----- Original Message -----
> >From: "Mark A Matte" <markamatte at hotmail.com>
> >To: <accessd at databaseadvisors.com>
> >Sent: Tuesday, May 08, 2007 12:55 PM
> >Subject: Re: [AccessD] Report to Excel_
> >
> >
> > > Thanks Jim,
> > >
> > > I need to export a report because of the conditional formatting.
> > > TransferSpreadsheet won't work with reports.
> > >
> > > Any thoughts?
> > >
> > > Thanks,
> > >
> > > Mark A. Matte
> > >
> > >
> > >>From: "Jim Hewson" <JHewson at karta.com>
> > >>Reply-To: Access Developers discussion and problem
> > >>solving<accessd at databaseadvisors.com>
> > >>To: "Access Developers discussion and problem
> > >>solving"<accessd at databaseadvisors.com>
> > >>Subject: Re: [AccessD] Report to Excel
> > >>Date: Mon, 7 May 2007 16:27:24 -0500
> > >>
> > >>Mark,
> > >>I do this frequently. In one export I end up with 15 worksheets and
> > >>manipulate the date in Excel via Access.
> > >>
> > >>I would use TransferSpreadsheet instead of what you have.
> > >>Also, put Set appExcel = New Excel.Application before the
> > >>TransferSpreadsheet command.
> > >>
> > >>If you use something like:
> > >>
> > >> DoCmd.TransferSpreadsheet acExport, , strReport1, strPathName,
>True
> > >> DoCmd.TransferSpreadsheet acExport, , strReport2, strPathName,
>True
> > >>
> > >>It will export to separate spreadsheets.
> > >>
> > >>HTH
> > >>
> > >>Jim
> > >>jhewson at karta.com
> > >>
> > >>
> > >>-----Original Message-----
> > >>From: accessd-bounces at databaseadvisors.com
> > >>[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Mark A
>Matte
> > >>Sent: Monday, May 07, 2007 4:00 PM
> > >>To: accessd at databaseadvisors.com
> > >>Subject: [AccessD] Report to Excel
> > >>
> > >>Hello All,
> > >>
> > >>I found the code below in the archives from Jim Hale...Anyway to use
> >this
> > >>approach but to have 2 reports go to the same workbook...just
>different
> > >>tabs?
> > >>
> > >>Thanks,
> > >>
> > >>Mark A. Matte
> > >>
> > >>*********Code From Jim****************
> > >>Sub rpt_to_excel()
> > >>Dim appExcel As Excel.Application, strpathname As String Dim
>strpathnew
> > >>As String, strReport As String
> > >>
> > >>strpathname = "C:\test.xls"
> > >>strpathnew = "C:\test2.xls"
> > >>strReport = "rptInvsummary"
> > >>DoCmd.OutputTo acOutputReport, strReport, acFormatXLS, strpathname
> > >>
> > >>Set appExcel = New Excel.Application
> > >>
> > >>'format your report
> > >> With appExcel
> > >> .Workbooks.Open strpathname, 0
> > >> .Visible = True 'just to watch the sheet
> > >> .Range("A1:G1").Select
> > >> .Selection.Font.Bold = True
> > >> .Selection.Font.Name = "Arial"
> > >> .Selection.Font.Size = 12
> > >> .ActiveWorkbook.SaveAs
> >Filename:=strpathnew,FileFormat:=xlNormal
> > >> End With
> > >> appExcel.Quit
> > >> Set appExcel = Nothing
> > >>End Sub
> > >>
_________________________________________________________________
PC Magazines 2007 editors choice for best Web mailaward-winning Windows
Live Hotmail.
http://imagine-windowslive.com/hotmail/?locale=en-us&ocid=TXT_TAGHM_migratio
n_HM_mini_pcmag_0507