Using Excell

[Animelion]

Can someone please post a simple working example of a VB program that takes an entered value and puts it into an excel file, and then saves the file. Also how to empty the contents of an array into a column and then save it.

I have found a few examples but have not been able to figure out how the code works, much thanks in advance.

~ Bryan J. Casler

[Pasvorto]

I use this subroutine to post production fugures from a VB proigram (SQL Server 2000) to an Excel spreadsheet
/============================

Public Sub T_UpdateExcel()
Screen.MousePointer = vbHourglass

On Error GoTo errorhandle

Dim xlApp As Excel.Application 'Excel object
Dim xlBook As Excel.workbook ' Workbook object
Dim xlSheet As Excel.Worksheet 'Worksheet object
Dim iJobNum As Long 'Job Number
Dim lProductAmount As Long 'Updated Job Amount
Dim WorkBookName As String
Dim WorkBookDir As String
Dim iworksheetcount As Integer
'
' First, backup Excel sheets just in case
'
Dim FileExtension As String
Dim SourcePath As String
Dim FileName As String

glbDate = CDate(InputBox("Enter Production Date"))
FileExtension = "*.xls"
SourcePath = "X:\"
FileName = Dir(SourcePath & FileExtension, vbNormal)

Do While FileName <> ""
frmProduction.lblMessage.Caption = "Copying ... " & FileName
frmProduction.lblMessage.Refresh
'========================
'set flag in case the copy
'blows up. I will know which
'file it was trying to copy
'==========================
msg = "1" & " " & FileName
FileCopy SourcePath & FileName, "Z:\DAD\EXCELBACKUP\" & FileName
FileName = Dir
Loop
frmProduction.lblMessage.Caption = ""
frmProduction.lblMessage.Refresh
MsgBox "Spreadsheets copied", vbInformation
msg = ""
'
'Now update the spreadsheets
'
'start Excel using automation
Set xlApp = CreateObject("Excel.Application")
WorkBookDir = "X:\"
'
'Select Production transactions
'
'===========================
Set rs = New ADODB.Recordset
'===========================
sql = "SELECT * FROM TRANS WHERE [DTE] = " & "'" & glbDate & "'"
rs.Open sql, CnxnTechSQL, adOpenKeyset, adLockReadOnly, adCmdText
If Not rs.BOF And Not rs.EOF Then
Dim totaljobs As Long
Dim KOUNTER As Long
KOUNTER = 0
rs.MoveLast
totaljobs = rs.RecordCount
rs.MoveFirst
Dim sqlJob As String
Do
KOUNTER = KOUNTER + 1
frmProduction.lblMessage.Caption = "Processing Job# " & rs![JOBNUM] & " -- " & Format(KOUNTER / totaljobs, "##0 %")
frmProduction.lblMessage.Refresh
'
'get workbook name from job record
'
'================================
Set rsJob = New ADODB.Recordset
'================================
sqlJobs = "SELECT * FROM JOBS WHERE [JOBNUMBER] = " & rs![JOBNUM]
sqlJobs = sqlJobs & " AND WORKBOOK IS NOT NULL"
rsJob.Open sqlJobs, CnxnTechSQL, adOpenKeyset, adLockReadOnly, adCmdText
If Not rsJob.BOF And Not rsJob.EOF Then
'open a workbook
If Len(rsJob![workbook]) = 0 Then
MsgBox "Job # " & rs![JOBNUM] & " has no workbook defined." & vbCrLf & "It will have to be updated by hand." & vbCrLf & "Write down the job number.", vbExclamation
rsJob.Close
Set rsJob = Nothing
'==================
GoTo continue
End If
'if not at last pass, don't update
'spreadsheet good prints
If rs![ENDPASS] < rsJob![PASSES] Then
rsJob.Close
Set rsJob = Nothing
'==================
GoTo continue
End If
'set workbook name
WorkBookName = WorkBookDir & UCase(rsJob![workbook]) & ".xls"
msg = "2 " '& WorkBookName
Set xlBook = xlApp.Workbooks.Open(WorkBookName)
Else
MsgBox "Job # " & rs![JOBNUM] & " not found." & vbCrLf & "It will have to be updated by hand." & vbCrLf & "Write down the job number.", vbExclamation
rsJob.Close
Set rsJob = Nothing
'==================
GoTo continue
End If
rsJob.Close
Set rsJob = Nothing
'==================
msg = ""
iJobNum = rs![JOBNUM]
lProductAmount = rs![GPRINTS]
'=================================
'don't know which worksheet to use
'so we will scroll through all of
'them until we find the job#
'=================================
iworksheetcount = xlBook.Worksheets.Count

For Y = 1 To iworksheetcount
'reference a specific worksheet number
Set xlSheet = xlBook.Worksheets(Y)
msg = "3 " '& xlBook.Worksheets(Y)
For X = 2 To 300
If xlSheet.Cells(X, 6).Value = "#" & iJobNum Then
'update the cell
If Trim(xlSheet.Cells(X, 8).Value) = "" Then
xlSheet.Cells(X, 8).Value = lProductAmount
Else
xlSheet.Cells(X, 8).Value = xlSheet.Cells(X, 8).Value + lProductAmount
End If
xlBook.Close savechanges:=True
GoTo continue 'no point looping anymore
End If
Next X
msg = ""
Next Y
continue:
rs.MoveNext
Loop While Not rs.EOF
End If
rs.Close
Set rs = Nothing
'===============
MsgBox "Spreadsheets updated", vbInformation
frmProduction.lblMessage.Caption = ""
frmProduction.lblMessage.Refresh

xlApp.Quit
Set xlApp = Nothing

Screen.MousePointer = 0
Exit Sub

errorhandle:
Screen.MousePointer = 0
If Left(msg, 1) = "1" Then
msg = Mid(msg, 2)
MsgBox "Couldn't copy " & msg & ". Contact Jerry..."
Screen.MousePointer = 0
' Resume Next
ElseIf Left(msg, 1) = "2" Then
MsgBox "Something went wrong updating Excel Spreadsheets." & vbCrLf & Err.Number & " " & Err.Description, vbExclamation
Screen.MousePointer = 0
Resume continue
Else
MsgBox "Something else went wrong updating Excel Spreadsheets." & vbCrLf & Err.Number & " " & Err.Description, vbExclamation
End If
End Sub

/=====================

You will have to wade through it and pick out the parts that are germane to you.