将窗体中的数据写入工作表编辑区

时　间:2016-08-28 09:04:35
作　者:杨雪   ID：42182  城市：南京
摘　要:    在导出一条记录时，导出一个字段的数据需要跳转至下一个单元格。在工作表中以单元格为基础进行跳转，可以使用Offset 方法实现：
正　文:

       在导出一条记录时，导出一个字段的数据需要跳转至下一个单元格。在工作表中以单元格为基础进行跳转，可以使用Offset 方法实现：

               [基础单元格].offset([跳转行数],[跳转列数])

源码：

Private Sub Command1_Click()
On Error GoTo 创建
    Dim xlApp As Object    'Excel.Application
    Dim xlWbk As Object    'Excel.Workbook
    Dim xlWsh As Object    'Excel.Worksheet
    Dim Rng1  As Object    'Excel.Range
    Dim Rng   As Object    'Excel.Range
    Dim rsNum As Integer
    Dim i As Integer
    Dim db As Database
    Dim rs As Recordset
    '激活指定工作表
    Set xlApp = GetObject(, "excel.application")
    xlApp.Visible = True
    Set xlWbk = xlApp.Workbooks.Open(CurrentProject.Path & "\示例工作簿.xlsx")
    Set xlWsh = xlWbk.Worksheets("sheet4")
    xlWsh.Activate
    '统计当前窗体中的记录数目
    rsNum = DCount("书籍编号", "存书查询")
    '将字段名称导出到Excel表格中作表头
    xlWsh.Range("A1").Value = Me.Label2.Caption
    xlWsh.Range("B1").Value = Me.Label3.Caption
    xlWsh.Range("c1").Value = Me.Label4.Caption
    xlWsh.Range("D1").Value = Me.Label5.Caption
    xlWsh.Range("E1").Value = Me.Label6.Caption
    xlWsh.Range("F1").Value = Me.Label7.Caption
    xlWsh.Range("G1").Value = Me.Label8.Caption
    'Excel表格定位至A2单元格
    Set Rng = xlWsh.Range("A2")

    '窗体中的记录定位至第一条记录
    DoCmd.GoToRecord , , acFirst
    '逐条导出窗体中的记录
    For i = 1 To rsNum
        Rng.Value = Me.书籍编号
        '导出一个数据之后跳转至表格的同一行下一列
        Set Rng = Rng.Offset(0, 1)
        Rng.Value = Me.书名
        Set Rng = Rng.Offset(0, 1)
        Rng.Value = Me.类别ID
        Set Rng = Rng.Offset(0, 1)
        Rng.Value = Me.作者
        Set Rng = Rng.Offset(0, 1)
        Rng.Value = Me.出版社ID
        Set Rng = Rng.Offset(0, 1)
        Rng.Value = Me.单价
        Set Rng = Rng.Offset(0, 1)
        Rng.Value = Format(Me.进书日期, "yyyy/mm/dd")
        '一条记录导出完之后，跳转至下一行第一列
        Set Rng = Rng.Offset(1, -6)
        DoCmd.GoToRecord acActiveDataObject, , acNext
    Next i
    '另存导出的Excel工作簿
    xlWbk.SaveAs CurrentProject.Path & "\存书查询" & Int(Rnd * 1000) & ".xlsx"

创建:
    If Err = 429 Then
        Set xlApp = CreateObject("excel.application")
        Resume Next
    End If

End Sub