将数据从Visual Basic 6传输到新的Excel工作表

祝大家好日子！

我需要一些帮助，我怎样才能将数据从VB6传输到一个新的Excel工作表，例如，我想能够select以前创build的Excel文件，添加一个新的工作表，并将数据保存到它。

以下是我目前与我的项目有关的内容：

Public Sub ExptExcel() Dim ADAExcelExpt As String Dim conn As New ADODB.Connection Dim RS As ADODB.Recordset With CommonDialog1 .CancelError = True .InitDir = "c:" .DialogTitle = "Save Excel File" .Filter = "Excel files (*.xls)|*.xls|Excel Files (*.xlsx)|*.xslx" .Flags = cdlOFNExplorer Or cdlOFNHideReadOnly Or cdlOFNLongNames On Error Resume Next 'trap the cancel error .ShowOpen End With If Err = cdlCancel Then 'user cancelled 'Exit Sub or msgbox "User cancelled." Exit Sub 'or whatever End If 'exit if no file selected If CommonDialog1.FileName = "" Then Exit Sub End If ADAExcelExpt = "E:\Remittance Report\PrintSource.mdb" conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ADAExcelExpt & ";" conn.CursorLocation = adUseClient Set RS = conn.Execute("Select FAGYDES, DedCode, FSERIAL, RANK, FULLNAME, DedAmt, FDEDDESC, FFULDESC, Datefm from tblPrintDeduct") 'Create a new workbook in Excel Dim oExcel As Object Dim oBook As Object Dim oSheet As Object Set oExcel = CreateObject("Excel.Application") Set oBook = oExcel.Workbooks.Add Set oSheet = oBook.Worksheets(1) 'Add headers to the worksheet on row 1 oSheet.Range("A1:I1").Value = Array("AGENCY", "DEDCODE", "AFPSN", "RANK", "FULLNAME", "AMOUNT", "DEDTYPE", "DESCRIPTION", "DATE") 'Transfer the data to Excel oSheet.Range("A2").CopyFromRecordset RS oBook.SaveAs (CommonDialog1.FileName) oExcel.Quit MsgBox ("File Exported!") 'Close the connection RS.Close conn.Close End Sub 

这个子参数只将我在窗体中的数据导出到新的工作簿中。

这是出口程序：

 Public Sub ExportToXL() Const SheetSize = 65000 'Number of records per Excel sheet Dim appExcel As Excel.Application Dim wkbWorkBook As Excel.Workbook Dim wksWorkSheet As Excel.Worksheet Dim rngYCursor As Excel.Range, rngXCursor As Excel.Range Dim ADAExcelExpt As String Dim conn As New ADODB.Connection Dim RS As ADODB.Recordset 'Dim RS As New ADODB.Recordset Dim i As Long, lngPN As Long Set appExcel = CreateObject("Excel.Application") With appExcel .Visible = True .UserControl = True Set wkbWorkBook = .Workbooks.Add End With With wkbWorkBook.Worksheets While .Count > 1 .Item(1).Delete Wend Set wksWorkSheet = .Item(1) End With With wksWorkSheet lngPN = 1 .Name = Me.cboDeduc.Text & " " & lngPN Set rngYCursor = .Range("A2") .Range("A1:I1").Value = Array("AGENCY", "DEDCODE", "AFPSN", "RANK", "FULLNAME", "AMOUNT", "DEDTYPE", "DESCRIPTION", "DATE") End With ADAExcelExpt = "E:\Remittance Report\PrintSource.mdb" conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ADAExcelExpt & ";" conn.CursorLocation = adUseClient Set RS = conn.Execute("Select FAGYDES, DedCode, FSERIAL, RANK, FULLNAME, DedAmt, FDEDDESC, FFULDESC, Datefm from tblPrintDeduct") While True For i = 1 To SheetSize Set rngXCursor = rngYCursor If RS.EOF Then GoTo ExitSub For Each fld In RS.Fields rngXCursor.Value = fld.Value Set rngXCursor = rngXCursor.Offset(ColumnOffset:=1) Next Set rngYCursor = rngYCursor.Offset(RowOffset:=1) RS.MoveNext Next i 'MsgBox ("File Exported!") Set wksWorkSheet = wkbWorkBook.Worksheets.Add(After:=wksWorkSheet) With wksWorkSheet lngPN = lngPN + 1 .Name = Me.cboDeduc.Text & " " & lngPN Set rngYCursor = .Range("A2") .Range("A1:I1").Value = Array("AGENCY", "DEDCODE", "AFPSN", "RANK", "FULLNAME", "AMOUNT", "DEDTYPE", "DESCRIPTION", "DATE") End With Wend 'End With ExitSub: RS.Close Set rngXCursor = Nothing Set rngYCursor = Nothing Set RS = Nothing Set wksWorkSheet = Nothing Set wkbWorkBook = Nothing Set appExcel = Nothing End Sub 

问候，

阿隆