LinkBack URL
About LinkBacksI'm using Excel 2000 to work on with a company payroll data. We put the data
from the
payroll into an excel workbook do some calculations and then use a macro to
split the
data into seperate workbooks by department and location. I'm using ADODB to
connect
the workbook back to itself so i can use SQL to select each
department/location in turn,
copy the recordset to a new workbook, add a code module to the new workbook
and then
save and close the new workbook.
Everything seems to work ok with the process itself but at the end of it I
end up with a
'ghost' excel process that if I don't 'end' manually using task manager I
can't rerun the
macro because the refernce to the data table can't be found.
I've read several postings about this type of behaviour and I've put extra
code in to make
sure I'm not accidently creating another instance of Excel but the problem
persists.
Can anyone shed any light on this.
Here is the code;
Sub testme1()
Dim cnnXL As ADODB.Connection 'Connection
Dim rstLocs As ADODB.Recordset 'Location Recordset
Dim rstEMPS As ADODB.Recordset 'Employee Recordset
Dim strConn As String 'Connection string
Dim strSQLLocs As String 'SQL for Locations
Dim strSQLEmps As String 'SQL for Employees within Location
Dim strSFName As String 'Workbook name for connection
Dim strShtName As String 'New worksheet name
Dim strPath As String 'Directory path for all files
Dim strNFName As String 'New File name (includes path)
Dim strWName As String 'Window Name (file name)
Dim strCName As String 'Code file name (includes path)
Dim intWSCnt As Integer 'Worksheet count
Dim intMax As Integer 'Progress Bar maximum
Dim intProg As Integer 'Progress Bar progress
Dim fsoCMod As FileSystemObject
Set appXL = GetObject(, "Excel.Application")
' Turn of screen updating
appXL.ScreenUpdating = False
' Setup fixed data variables
strSFName = appXL.ThisWorkbook.Name
strPath = appXL.ThisWorkbook.Path
strCName = strPath & "\code.txt"
' Export the module that will contain code for the workbooks created by
this macro
appXL.ThisWorkbook.Activate
appXL.ThisWorkbook.VBProject.VBComponents("basExport").Export strCName
' Setup an ADODB connection to this workbook
Set cnnXL = New ADODB.Connection
cnnXL.Provider = "MSDASQL"
cnnXL.ConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)}; DBQ="
& strSFName
cnnXL.Open
' Set the SQL to get a unique list of locations and create the recordset
strSQLLocs = "SELECT DISTINCT [AllData].[Substantive Location],
[AllData].[Substantive Group] "
strSQLLocs = strSQLLocs & "FROM [AllData] ORDER BY
[AllData].[Substantive Location]"
Set rstLocs = cnnXL.Execute(strSQLLocs)
' Error if data not present
If rstLocs.BOF And rstLocs.EOF Then
MsgBox "Problem"
Exit Sub
End If
' Setup progress bar and display
intMax = 60
intProg = 1
ProgBar (intProg / intMax) * 100
' Loop through the recordset of locations
Do Until rstLocs.EOF
' create a new workbook and reduce the number of worksheets to 1
appXL.Workbooks.Add
intWSCnt = appXL.ActiveWorkbook.Sheets.Count
appXL.DisplayAlerts = False
If intWSCnt > 1 Then
Do Until appXL.ActiveWorkbook.Sheets.Count = 1
appXL.ActiveWorkbook.Sheets(appXL.ActiveWorkbook.Sheets.Count).Delete
Loop
End If
appXL.DisplayAlerts = True
' Strip special characters from location name and use as workbook name
strNFName = rstLocs(0) & " " & rstLocs(1)
If InStr(1, strNFName, "/", vbTextCompare) > 0 Then
strNFName = Replace(strNFName, "/", " ", 1, , vbTextCompare)
ElseIf InStr(1, strNFName, "&", vbTextCompare) > 0 Then
strNFName = Replace(strNFName, "&", " ", 1, , vbTextCompare)
Else
strNFName = strNFName
End If
strWName = strNFName
strNFName = strPath & "\" & strNFName
appXL.ActiveWorkbook.SaveAs strNFName
' Copy data column headings from this workbook and paste into new workbook
appXL.ThisWorkbook.Activate
appXL.Range("ColHeads").Copy
appXL.Workbooks(strWName).Activate
appXL.ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial
' Import the code module to be used in the new workbook
appXL.Workbooks(strWName).Activate
appXL.ActiveWorkbook.VBProject.VBComponents.Import strCName
' Save the new workbook
appXL.ActiveWorkbook.Save
' Switch to this workbook
appXL.ThisWorkbook.Activate
' Set the SQL to extract the data for a given location
strSQLEmps = "SELECT * FROM [AllData] WHERE ([AllData].[Substantive
Location]='" & rstLocs(0)
strSQLEmps = strSQLEmps & "' AND [AllData].[Substantive Group]='" &
rstLocs(1) & "' )"
' Create a recordset containg the employees for a given location
Set rstEMPS = New ADODB.Recordset
Set rstEMPS = cnnXL.Execute(strSQLEmps)
' Swithc to the new workbook and insert the data from the employee recordset
appXL.Workbooks(strWName).Activate
appXL.Selection.Offset(1, 0).CopyFromRecordset rstEMPS
' Save the new workbook
appXL.ActiveWorkbook.Save
appXL.ActiveWorkbook.Close
appXL.ThisWorkbook.Activate
' Close the employee recordset
rstEMPS.Close
Set rstEMPS = Nothing
' loop to the next location
rstLocs.MoveNext
' update progress bar
intProg = intProg + 1
ProgBar (intProg / intMax) * 100
Loop
' Close location recordset
rstLocs.Close
Set rstLocs = Nothing
' Close the connection to the workbook
cnnXL.Close
Set cnnXL = Nothing
' Delete code module
Set fsoCMod = CreateObject("Scripting.FileSystemObject")
If fsoCMod.FileExists(strCName) Then
fsoCMod.DeleteFile strCName
End If
Set fsoCMod = Nothing
' Reset screen updating and status bar
appXL.ScreenUpdating = False
appXL.StatusBar = ""
Set appXL = Nothing
End Sub
--
Paul
Register To Reply
Bookmarks