Here you'll find various samples:http://www.zmey.1977.ru/Access_To_Excel.htm

zmey,

Sorry for the delay.  Been out of town and away from a terminal.

Thanks for the references on your site.  They provide insight into the options internal to the MS apps (vba and other techniques) and external (vbs and ADODB).

ADODB is the solution I want.  I can currently load everything into one spreadsheet within a workbook.  What I need is help, code preferably that will:

1) Create a Recordset
2) Create a workbook
3) Use a filter or other means to determine a records from the recordset that need to be added to a specific worksheet. Ex. all TX (Texas) records.
4) Create a worksheet and name it based on that criteria (ex TX)
5) Add all records meeting that criteria to the worksheet,
6) Save it
7) Loop back to 3 until all worksheets needing to be created, named and records added to it.
8) Close the objects openned at their appropriate time.
9) Any error trapping one would deem necessary.

I can upload my working code, or atleast as far as I have it, if that will assist.

Again, thanks for your response.

Have a great day.

DougCranston

Zmey2,

I am trying to adapt your code to my application/environment.  Had to deal with some user problems and shot most of the day on that. I think I comprehend at least half of what your doing, before I begin digging out my reference books.  Will work on it at home tonight and let you know tomorrow.

Thanks, and if this does solve my problem you got the points.

Doug Cranston

Zmey2,

I have tried to merge your code with what I had working and I am at a loss.  The mixed (yours and my code) is as follows.....

'~~ScriptName~~.        tstrprts.vbs
'----------------------------------------------------
'~~Author~~.          Doug Cranston/William Klein
'~~Email_Address~~.   douglas.cranston@verizon.com/william.klein@verizon.com
'~~Script_Type~~.     VBScript
'~~Sub_Type~~.
'~~Prerequisites~~.   VBScript 5.0
'~~Version~~.         1.0
'~~Date Created~~.    2/6/2003
'~~Version_History~~. Initial version
'~~Keywords~~.        File exists, FileSystemObject
'~~Description~~.     Test if a folder exists and creates one if not.
'                     Tests for file exists and deletes if exists.
'                     Creates an Excel spread, extracts data from
'                     Access MDB via ADO and DSN. Formats the spreadsheet
'                     saves File.
'========= Declarations =================
'Option Explicit


' Dim variables
Dim cn
Dim rs1
Dim rs2
Dim sql
Dim sql2
Dim fldmax
Dim rowmax
Dim rowmax2
Dim xlApp
Dim xlWb
Dim xlWs
Dim iCol
Dim iRow2
Dim iRow
Dim recArray
Dim recCount
Dim result
Dim filesys
Dim newfolder
Dim storedfldr
Dim storedfile
Dim storedFilenm
Dim objMessage

' Assign Constants




Call CreateDir

Call ClearFile

Call CreateRpt

Public Sub CreateDir()
' Test to see if Folder Exists and if not create it
    storedFilenm = "rcerprts.xls"
    storedfile = storedfldr & "\" & storedFilenm
    storedfldr = "c:\cmdfiles\tempfile"

    Set filesys = CreateObject("Scripting.FileSystemObject")
    If Not filesys.FolderExists(storedfldr) Then
       Set newfolder = filesys.CreateFolder(storedfldr)
    End If
End Sub

Public Sub ClearFile()
' Test if Old version of file exists delete it
    storedFilenm = "rcerprts.xls"
    storedfile = storedfldr & "\" & storedFilenm
    storedfldr = "c:\cmdfiles\tempfile"
   
    filesys.CreateTextFile storedfile, True
    If filesys.FileExists(storedfile) Then
       filesys.DeleteFile storedfile
    End If
End Sub

Sub CreateRpt()
' Connect to the db with a DSN-less connection
' --- Create Instance of Connection Object ---
  Set cn = Wscript.CreateObject("ADODB.Connection")
  cn.Open "DSN=rptrqst"

' Create a server recordset object
  Set rs1 = Wscript.CreateObject("ADODB.Recordset")

' Define Query to determine select criteria
    sql2 = "SELECT DISTINCTROW tblStores.txtRegion, "
    sql2 = sql2 & "FROM tblStores "
    sql2 = sql2 & "ORDER BY tblStores.txtRegion;"

' Execute the sql
  rs1.Open sql2, cn, 3, 3

'this opens a recordset with all unique names in Field
    If Not rs1.EOF Then
        rs1.MoveLast
        rs1.movefirst
        rowmax2 = rs1.RecordCount
    End If

' Create an instance of Excel and add a workbook
    Set xlApp = CreateObject("Excel.Application")
'this required to determine recordcount
    xlApp.SheetsInNewWorkbook = rs1.RecordCount

'create a workbook with required sheets number
    Set xlWb = xlApp.Workbooks.Add

'these are coordinates of top left corner
    x = 1
    y = 1

'cycle tru sheets
  For i = 1 To rowmax2
    Set xlWs = xlWb.Worksheets(i)
    xlWs.Name = rs1(0)
    Call TXLOut(sql, WS, x, y, n, m, True)
    rs1.movenext
    Next i

' Close and set the recordset to nothing
    rs1.Close
    Set rs1 = Nothing
    rs2.Close
    Set rs2 = Nothing

' Close and set the connection to nothing
    cn.Close
    Set cn = Nothing
   
' Save the spreadsheet as
    xlWb.SaveAs ("c:\cmdfiles\tempfile\rcerprts.xls")
    Set xlSheet = Nothing
    xlWb.Close False '/False to ignore changes '/ True to save changes
    Set xlWb = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    Set filesys = Nothing
End Sub


Public Function TXLOut(sql As String, Optional WS As Worksheet = Nothing, Optional ByRef x As Long = 1, Optional ByRef y As Long = 1, Optional ByRef n As Long = 1, Optional ByRef m As Long = 1, Optional Headers As Boolean = True) As Worksheet
'Notice, that you need References to ADO

' Define main query
    sql = "SELECT DISTINCTROW tblStores.txtStoreNo, "
    sql = sql & "tblStores.txtStoreRCECd, tblStores.txtRegion, "
    sql = sql & "tblStores.txtStoreName, "
    sql = sql & "tblStores.txtState, "
    sql = sql & "tblRequests.dtRqstSubmitted, "
    sql = sql & "tblRequests.dtRptDate, tblRequests.txtRptType, "
    sql = sql & "LCase([txtRequestor]), "
    sql = sql & "tblRequests.txtBatchNo, "
    sql = sql & "LCase([txtRqstReason]), 1 "
    sql = sql & "FROM tblRequests INNER JOIN tblStores "
    sql = sql & "ON tblRequests.txtStoreRCECd = tblStores.txtStoreRCECd "
    sql = sql & "WHERE (((tblRequests.dtRqstSubmitted) Between #11/1/2002# And #11/30/2002#)) "
    sql = sql & "AND tblStores.txtRegion = '" & rs(0) & "' "
    sql = sql & "ORDER BY tblStores.txtRegion, "
    sql = sql & "tblRequests.txtRptType, "
    sql = sql & "tblRequests.dtRptDate;"

' Execute the sql
    rs2.Open sql, cn, 3, 3

' Determine the array we are dealing with
    If Not rs2.BOF And Not rs2.EOF Then
      rs2.MoveFirst()
      rs2.MoveLast()
      rowmax = rs2.RecordCount
      fldmax = rs2.Fields.Count
    End If

' Block display Excel and user control of Excel's lifetime
' FOR TESTING SET BOTH TO TRUE
    xlApp.Visible = True
    xlApp.UserControl = True
     
' Set field names to the first row of the worksheet
    xlWs.Cells(1, 1).Value = "Store#"
    xlWs.Cells(1, 2).Value = "RCE Cd"
    xlWs.Cells(1, 3).Value = "Region"
    xlWs.Cells(1, 4).Value = "Store Name"
    xlWs.Cells(1, 5).Value = "State"
    xlWs.Cells(1, 6).Value = "Dt Sbmtd"
    xlWs.Cells(1, 7).Value = "Rprt Dt"
    xlWs.Cells(1, 8).Value = "Rpt Type"
    xlWs.Cells(1, 9).Value = "Requestor"
    xlWs.Cells(1, 10).Value = "Batch #"
    xlWs.Cells(1, 11).Value = "Reason"

' Set Column Widths
    xlWs.Columns(1).ColumnWidth = 5.57
    xlWs.Columns(2).ColumnWidth = 5.57
    xlWs.Columns(3).ColumnWidth = 4
    xlWs.Columns(4).ColumnWidth = 19.75
    xlWs.Columns(5).ColumnWidth = 4
    xlWs.Columns(6).ColumnWidth = 9.3
    xlWs.Columns(7).ColumnWidth = 9.3
    xlWs.Columns(8).ColumnWidth = 8.3
    xlWs.Columns(9).ColumnWidth = 16.86
    xlWs.Columns(10).ColumnWidth = 5.57
    xlWs.Columns(11).ColumnWidth = 25

' Set first row as column titles over mult pages
    With xlWs.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    xlWs.PageSetup.PrintArea = ""

' Set Page header and footers, page margins, layout
   xlWs.PageSetup.PrintArea = ""
    With xlWs.PageSetup
        .LeftHeader = ""
        .CenterHeader = "RCE Reprint Requests - Sorted by Store/Report Type/Report Date"
        .RightHeader = ""
        .LeftFooter = "&F"
        .CenterFooter = "Page - &P"
        .RightFooter = "&D &T"
        .LeftMargin = xlApp.InchesToPoints(0.5)
        .RightMargin = xlApp.InchesToPoints(0.5)
        .TopMargin = xlApp.InchesToPoints(0.8)
        .BottomMargin = xlApp.InchesToPoints(0.8)
        .HeaderMargin = xlApp.InchesToPoints(0.5)
        .FooterMargin = xlApp.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = -4142
        .Orientation = 2 ' landscape
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Draft = False
        .PaperSize = 1 ' xlPaperLetter
        .FirstPageNumber = 1 ' xlAutomatic
        .Order = 1 ' xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
    End With

' Move to first record in recordset
    rs2.movefirst

' Set counter for positioning data posting
    iRow2 = 2

' Start a for/next loop that will end with the last record
    For iRow = iRow2 To rowmax
        For iCol = 1 To fldmax
            If (rs.Fields.Item(iCol - 1) = "") Then
                xlWs.Cells(iRow, iCol).Value = ""
            Else
                xlWs.Cells(iRow, iCol).Value = rs.Fields(iCol - 1).Value
            End If
        Next
        iRow2 = iRow2 + 1
' Move to the next record
      rs2.movenext
    Next

' Set formatting for entire sheet
    xlWs.Range("A1:" & PickCol(fldmax) & rowmax).Select
    xlWs.Range("A1:" & PickCol(fldmax) & rowmax).Font.Name = "Times New Roman"
    xlWs.Range("A1:" & PickCol(fldmax) & rowmax).Font.Size = 8
    xlWs.Range("A1:" & PickCol(fldmax) & rowmax).Font.Bold = True
    xlWs.Range("A1:" & PickCol(fldmax) & rowmax).WrapText = True

' Set shading for column titles
    With xlWs.Range("A1:k1")
        .Interior.Color = RGB(196, 196, 196)
    End With

' Set lines around cells
    With xlWs.Range("A1:" & PickCol(fldmax) & rowmax)
      With .Borders(7)
            .LineStyle = 1
          .Weight = 2
        .Color = RGB(0, 0, 0)
        End With
      With .Borders(8)
            .LineStyle = 1
          .Weight = 2
        .Color = RGB(0, 0, 0)
        End With
      With .Borders(9)
            .LineStyle = 1
          .Weight = 2
        .Color = RGB(0, 0, 0)
        End With
      With .Borders(10)
            .LineStyle = 1
          .Weight = 2
        .Color = RGB(0, 0, 0)
        End With
      With .Borders(11)
            .LineStyle = 1
          .Weight = 2
        .Color = RGB(0, 0, 0)
        End With
      With .Borders(12)
            .LineStyle = 1
          .Weight = 2
        .Color = RGB(0, 0, 0)
        End With
    End With

End Function



' Translates cell column # to Alpha Char for cell ref
Function PickCol(fldmax)

    Select Case fldmax
        Case 1
           result = "A"
        Case 2
           result = "B"
        Case 3
           result = "C"
        Case 4
           result = "D"
        Case 5
           result = "E"
        Case 6
           result = "F"
        Case 7
           result = "G"
        Case 8
           result = "H"
        Case 9
           result = "I"
        Case 10
           result = "J"
        Case 11
           result = "K"
        Case 12
           result = "L"
        Case 13
           result = "M"
        Case 14
           result = "N"
        Case 15
           result = "O"
        Case 16
           result = "P"
        Case 17
           result = "Q"
        Case 18
           result = "R"
        Case 19
           result = "S"
    End Select
    PickCol = result
End Function

============
However my working code that pulls all records and drops it into ONE spreadsheet is as follows:

'~~ScriptName~~.        rcerprts.vbs
'----------------------------------------------------
'~~Author~~.          Doug Cranston/William Klein
'~~Email_Address~~.   douglas.cranston@verizon.com/william.klein@verizon.com
'~~Script_Type~~.     VBScript
'~~Sub_Type~~.        
'~~Prerequisites~~.   VBScript 5.0
'~~Version~~.         1.0
'~~Date Created~~.    2/6/2003
'~~Version_History~~. Initial version
'~~Keywords~~.        File exists, RegExp object, FileSystemObject
'~~Description~~.     Test if a folder exists and creates one if not.
'                     Tests for file exists and deletes if exists.
'                     Creates an Excel spread, extracts data from
'                     Access MDB via ADO and DSN. Formats the spreadsheet
'                     saves File.
'~~Enhancements~~.    Incorporated CDONTS NT Emailing AND CDO for Win2k
'~~Ideas for improvement    
'                     Incorporate testing if changes to db to trigger this
'                     SeePURGEFILES.vbs uses the LastModifiedDate of a file and deletes it
'    http://cwashington.netreach.net/depo/default.asp?topic=repository&ScriptType=vbscript&SubType=FileSystem

'========= Declarations =================
' Dim variables
dim cn
dim rs
dim sql
dim fldmax
dim rowmax
Dim xlApp
Dim xlWb
Dim xlWs
Dim iCol
Dim iRow2
Dim iRow
Dim recArray
Dim recCount
dim result
dim filesys
dim newfolder
dim storedfldr
dim storedfile
dim storedFilenm
dim objMessage

' Assign Constants
storedfldr = "c:\cmdfiles\tempfile"
storedFilenm = "rcerprts.xls"
storedfile = storedfldr & "\" & storedFilenm

' Test to see if Folder Exists and if not create it
Set filesys = CreateObject("Scripting.FileSystemObject")
If Not filesys.FolderExists(storedfldr) Then
   set newfolder = filesys.CreateFolder(storedfldr)
End If

' Test if Old version of file exists delete it
filesys.CreateTextFile storedfile, True
If filesys.FileExists(storedfile) Then
   filesys.DeleteFile storedfile
End If

' Connect to the db with a DSN-less connection
' --- Create Instance of Connection Object ---
Set cn = Wscript.CreateObject("ADODB.Connection")
cn.Open "DSN=rcerpt"

' Create a server recordset object
Set rs = Wscript.CreateObject("ADODB.Recordset")

' Select all data from the query
'sql = "qryMnthEndRpt"

sql = "SELECT DISTINCTROW tblStores.txtStoreNo, "
sql = sql & "tblStores.txtStoreRCECd, tblStores.txtRegion, "
sql = sql & "tblStores.txtStoreName, "
sql = sql & "tblStores.txtState, "
sql = sql & "tblRequests.dtRqstSubmitted, " 
sql = sql & "tblRequests.dtRptDate, tblRequests.txtRptType, "
sql = sql & "LCase([txtRequestor]), "
sql = sql & "tblRequests.txtBatchNo, "
sql = sql & "LCase([txtRqstReason]), 1 "
sql = sql & "FROM tblRequests INNER JOIN tblStores "
sql = sql & "ON tblRequests.txtStoreRCECd = tblStores.txtStoreRCECd "
sql = sql & "WHERE (((tblRequests.dtRqstSubmitted) Between #11/1/2002# And #11/30/2002#)) "
sql = sql & "ORDER BY tblStores.txtRegion, "
sql = sql & "tblRequests.txtRptType, "
sql = sql & "tblRequests.dtRptDate;"

' Execute the sql
rs.Open sql, cn,3, 3

' Determine the array we are dealing with
If Not rs.BOF and Not rs.EOF then
  rs.MoveLast()
  rowmax = rs.RecordCount
  fldmax = rs.Fields.Count
end if

' Create an instance of Excel and add a workbook
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets("Sheet1")
xlApp.Sheets(1).activate
xlApp.Sheets(1).Name = "RceRprtS"
   
' Block display Excel and user control of Excel's lifetime
' FOR TESTING SET BOTH TO TRUE
xlApp.Visible = True
xlApp.UserControl = True
     
' Set field names to the first row of the worksheet
xlWs.Cells(1,1).Value = "Store#"
xlWs.Cells(1,2).Value = "RCE Cd"
xlWs.Cells(1,3).Value = "Region"
xlWs.Cells(1,4).Value = "Store Name"
xlWs.Cells(1,5).Value = "State"
xlWs.Cells(1,6).Value = "Dt Sbmtd"
xlWs.Cells(1,7).Value = "Rprt Dt"
xlWs.Cells(1,8).Value = "Rpt Type"
xlWs.Cells(1,9).Value = "Requestor"
xlWs.Cells(1,10).Value = "Batch #"
xlWs.Cells(1,11).Value = "Reason"

' Set Column Widths
xlWs.Columns(1).ColumnWidth = 5.57
xlWs.Columns(2).ColumnWidth = 5.57
xlWs.Columns(3).ColumnWidth = 4
xlWs.Columns(4).ColumnWidth = 19.75
xlWs.Columns(5).ColumnWidth = 4
xlWs.Columns(6).ColumnWidth = 9.3
xlWs.Columns(7).ColumnWidth = 9.3
xlWs.Columns(8).ColumnWidth = 8.3
xlWs.Columns(9).ColumnWidth = 16.86
xlWs.Columns(10).ColumnWidth = 5.57
xlWs.Columns(11).ColumnWidth = 25

' Set first row as column titles over mult pages
    With xlWs.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    xlWs.PageSetup.PrintArea = ""

' Set Page header and footers, page margins, layout
   xlWs.PageSetup.PrintArea = ""
    With xlWs.PageSetup
        .LeftHeader = ""
        .CenterHeader = "RCE Reprint Requests - Sorted by Store/Report Type/Report Date"
        .RightHeader = ""
        .LeftFooter = "&F"
        .CenterFooter = "Page - &P"
        .RightFooter = "&D &T"
        .LeftMargin = xlApp.InchesToPoints(0.5)
        .RightMargin = xlApp.InchesToPoints(0.5)
        .TopMargin = xlApp.InchesToPoints(0.8)
        .BottomMargin = xlApp.InchesToPoints(0.8)
        .HeaderMargin = xlApp.InchesToPoints(0.5)
        .FooterMargin = xlApp.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = -4142
        .Orientation = 2 ' landscape
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Draft = False
        .PaperSize = 1 ' xlPaperLetter
        .FirstPageNumber = 1 ' xlAutomatic
        .Order = 1 ' xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
    End With

' Move to first record in recordset
rs.movefirst

' Set counter for positioning data posting
iRow2 = 2

' Start a for/next loop that will end with the last record
For iRow = iRow2 To rowmax
      For iCol = 1 to fldmax
            If (rs.Fields.Item(iCol-1)="") Then
                  xlWs.Cells(iRow,iCol).value = ""
            Else
                  xlWs.Cells(iRow,iCol).value = rs.Fields(iCol -1).value
            End If
      Next
      iRow2=iRow2+1
      ' Move to the next record
rs.movenext
Next

' Set formatting for entire sheet
xlWs.Range("A1:" & PickCol(fldmax) & rowmax).Select  
xlWs.Range("A1:" & PickCol(fldmax) & rowmax).Font.Name = "Times New Roman"
xlWs.Range("A1:" & PickCol(fldmax) & rowmax).Font.Size = 8
xlWs.Range("A1:" & PickCol(fldmax) & rowmax).Font.Bold = True
xlWs.Range("A1:" & PickCol(fldmax) & rowmax).WrapText = True

' Set shading for column titles
    With xlWs.Range("A1:k1")
          .Interior.Color = RGB(196,196,196)
    End With

' Set lines around cells
  With xlWs.Range("A1:" & PickCol(fldmax) & rowmax)
    with .Borders(7)
            .LineStyle = 1
          .Weight = 2
             .Color = RGB(0,0,0)
      end with
    with .Borders(8)
            .LineStyle = 1
          .Weight = 2
             .Color = RGB(0,0,0)
      end with
    with .Borders(9)
            .LineStyle = 1
          .Weight = 2
             .Color = RGB(0,0,0)
      end with
        with .Borders(10)
            .LineStyle = 1
          .Weight = 2
             .Color = RGB(0,0,0)
      end with
    with .Borders(11)
            .LineStyle = 1
          .Weight = 2
          .Color = RGB(0,0,0)
      end with
    with .Borders(12)
            .LineStyle = 1
          .Weight = 2
           .Color = RGB(0,0,0)
      end with      
  End With

' Close and set the recordset to nothing
rs.close
set rs=nothing

' Close and set the connection to nothing
cn.close
set cn=nothing

' Save the spreadsheet as
xlWb.SaveAs("c:\cmdfiles\tempfile\rcerprts.xls")
' Closes ALL open spreadsheets
'xlWb.Close

' Release Excel references
Set xlWs = Nothing
Set xlWb = Nothing
Set xlApp = Nothing

'Sending a text email with an attached file  
' If used on WIN2 Server/WS remove the double ''
' and then comment out the CDODNTS
Set objMessage = CreateObject("CDO.Message")

'Sending a text email using a remote server  

'Set objMessage = CreateObject("CDO.Message")
''objMessage.Subject = "RceRprtS.xls Update"
''objMessage.Sender = "william.klein@verizon.com"
' Testing purposes - Sender & To same
''objMessage.To = "william.klein@verizon.com"
''objMessage.To = "posteam@list.tel.gte.com"
''objMessage.Cc = "kay.schwartz@verizon.com"
''objMessage.AddAttachment "c:\cmdfiles\tempfile\rcerpts.xls"
''objMessage.TextBody = "The attached file is the latest Monthly RCE Reprint list sorted by Region/Store/Submitted Date."

'==This section provides the configuration information for the remote SMTP server.
'==Normally you will only change the server name or IP.

''objMessage.Configuration.Fields.Item _
''("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

'Name or IP of Remote SMTP Server
''objMessage.Configuration.Fields.Item _
''("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.tel.gte.com"

'Server port (typically 25)
''objMessage.Configuration.Fields.Item _
''("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

''objMessage.Configuration.Fields.Update

'==End remote SMTP server configuration section==

''objMessage.Send


' CDONTS email for NT
' Dim MyBody
' Dim MyCDONTSMail

' set MyCDONTSMail = CreateObject("CDONTS.NewMail")

' MyCDONTSMail.Subject = "RceRprtS.xls Update"
' MyCDONTSMail.From = "william.klein@verizon.com"
' Testing purposes - From & To same
' MyCDONTSMail.To = "william.klein@verizon.com"
' MyCDONTSMail.Cc = "kay.schwartz@verizon.com"
' MyCDONTSMail.AttachFile("c:\cmdfiles\tempfile\rcerprts.xls")
' MyCDONTSMail.Body = "The attached file is the latest Monthly RCE Reprint list sorted by Region/Store/Submitted Date." & VbCrLf
' MyCDONTSMail.Send
' set MyCDONTSMail=nothing


' Translates cell column # to Alpha Char for cell ref
Function PickCol(fldmax)

      Select Case fldmax
            Case 1
               result = "A"
            Case 2
               result = "B"
            Case 3
               result = "C"
            Case 4
               result = "D"
            Case 5
               result = "E"
            Case 6
               result = "F"  
            Case 7
               result = "G"
            Case 8
               result = "H"
            Case 9
               result = "I"  
            Case 10
               result = "J"
            Case 11
               result = "K"
            Case 12
               result = "L"  
            Case 13
               result = "M"  
            Case 14
               result = "N"
            Case 15
               result = "O"
            Case 16
               result = "P"  
            Case 17
               result = "Q"
            Case 18
               result = "R"
            Case 19
               result = "S"
      End Select
    PickCol = result
End Function

Any suggestions...?  Help..

Thanks

Doug Cranston

Think that will take me two weeks to understand code, since i don't have your tables.
That will help much if you explain what problems have you got in your code and where exactly.

Zmey2,

Got a scaled down version of the script to function based on your script and several hours of pulling out what is left of my hair.

If I may, one last question in parting.

Running this vbs script from the Command prompt runs fine.  Can script it with "AT".

But in both cases when the scripts complete, it leaves an instance of EXCEL in the TaskMgr. (PID and 5+Meg Ram) tied up.

When I run the program from an "at" as a scheduled job, or from the command prompt I am using a cmd of:  cscript c:\cmdfiles\scriptname.vbs  

In the case of "AT" I set the time and log off.  When I come back, the script has run, but when I look in TaskMgr, I see Excel still running (No resources just sitting there and taking up RAM resources).  

I have the following code:

xlWb.SaveAs("c:\cmdfiles\tempfile\rcerpts.xls")

' Release Excel and FSO Objects and references
        xlWb.Close True
        Set xlSheet = Nothing
        Set xlWb = Nothing
        xlApp.Quit
        Set xlApp = Nothing
       Set filesys = Nothing

I had some problems over the past weekend that caused the webserver to choke doing the same thing of using an "AT" job to pull the information via cscript & VBS, and found the same thing.  Instantiates Excel but does not release it.

 I found several references on other sites that suggested the code following the "Release Excel ..."  It stopped my having "cscript" still in the taskmanager but it still is leaving the Excel there.

Any suggestions.

Thanks, and thanks again for your code snippet.

Doug Cranston

Zmey2 and et al,

Clarification.

Running the job either via AT or command line, creates an INDIVIDUAL EXCEL instance, for each time it is run.  So run the script 4 times and I not only have 4 instances of Excel but 20MB RAM tied up.

Reread my comments and I noted I had forgot to indicate the significance (# times run = Addl resources allocated and tied up)

Thanks,

Doug Cranston

Check if you have any add-ins installed in excel. Uncheck if any.

Not an Addin problem.  Wannabe programmer issue.

I had one instantiation of an object that I was not releasing and that appears to have been the problem.

Coding is working.  Just have to fine tune some error trapping and reset and test the automated emailing.

Thanks again for the help.

Will accept your answer after submitting this note.

Appreciate it.

Doug Cranston

Zmey2 provided me enough direction that I could make progress.  Almost have the app in the "can."

Thanks to Experts-Exchange and Zmey2.

This question can be closed.

Doug Cranston

>Not an Addin problem.  
I mean sometimes excel won't offload because of add-in.
Another possible problem if you have ole objects embedded and you don't quit the appropriate ole server. Check if any other processes remain in memory as well as excel.