导入EXCLE保存问题？？？急

Question

怎么让我的程序把记录导入EXCLE中自动保存为指定的文名呢？？谢谢

Answer 1

给你个例子，改改可以用   Dim excelApp As Object
    Dim excelBook As Object
    Dim excelSheet As Object
    Dim recCount As Long
    Dim fldCount As Integer
    Dim mValue As Variant
    Dim startRow As Integer
    Dim col As Integer
    Dim row As Integer
    Dim s As String
    Dim i As Long
    
    
    If Len(txtExcelTargetSpec) = 0 Then
         MsgBox "请选择或输入Excel的名称"
         Exit Sub
    ElseIf IsFileThere(txtExcelTargetSpec) Then
        If MsgBox("此名称的Excel文件已经存在. 要覆盖么?", vbYesNo + vbQuestion) <> vbYes Then
             Exit Sub
        End If
    End If
    
    
    Screen.MousePointer = vbHourglass
    Lblprogressmsg.Visible = True
    Label1.Visible = False
    If frmlookup.datPrimaryRS.EOF() Then
         Screen.MousePointer = vbDefault
         Lblprogressmsg.Visible = False
         Label1.Visible = True
         MsgBox "选中的表中无记录！"
         Exit Sub
    End If
    frmlookup.datPrimaryRS.MoveLast
    recCount = frmlookup.datPrimaryRS.RecordCount
    frmlookup.datPrimaryRS.MoveFirst
    fldCount = frmlookup.datPrimaryRS.Fields.Count
    If fldCount = 0 Then
         Screen.MousePointer = vbDefault
         Lblprogressmsg.Visible = False
         Label1.Visible = True
         MsgBox "选中的表中无字段！"
         Exit Sub
    ElseIf recCount = 0 Then
         Screen.MousePointer = vbDefault
         Lblprogressmsg.Visible = False
         Label1.Visible = True
         MsgBox "选中的表中无记录"
         Exit Sub
    End If
    
    On Error Resume Next
    Set excelApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
         Set excelApp = CreateObject("Excel.Application")
    End If
    On Error GoTo errHandler
    
    Set excelBook = excelApp.Workbooks.Add
    Set excelSheet = excelBook.Worksheets(1)
    If Val(excelApp.Application.Version) >= 8 Then
        Set excelSheet = excelApp.ActiveSheet
    Else
        Set excelSheet = excelApp
    End If
    
    startRow = 1
    If ckbWithHeadings.Value = vbChecked Then
         ' Write field names
        For col = 1 To fldCount
              ' We exclude adVarBinary (type=204), adlongVarBinary (205)
              ' adBinary (type=128) and adBSTR (type=8) types of fields
            s = CStr(frmlookup.datPrimaryRS.Fields(col - 1).Type)
            If Len(s) = 1 Then
                 s = "XX" & s
            ElseIf Len(s) = 2 Then
                 s = "X" & s
            End If
            If InStr(mconexcludeFieldTypes, s) = 0 Then
                 excelSheet.Cells(1, col) = frmlookup.datPrimaryRS.Fields(col - 1).Name
            End If
        Next col
        startRow = 2
    End If
    
      ' Write values
    For row = startRow To recCount + 1
        For col = 1 To fldCount
              ' We exclude adVarBinary (type=204), adlongVarBinary (205)
              ' adBinary (type=128) and adBSTR (type=8) types of fields
            s = CStr(frmlookup.datPrimaryRS.Fields(col - 1).Type)
            If Len(s) = 1 Then
                 s = "XX" & s
            ElseIf Len(s) = 2 Then
                 s = "X" & s
            End If
            If InStr(mconexcludeFieldTypes, s) = 0 Then
                 mValue = frmlookup.datPrimaryRS.Fields(col - 1).Value
                 excelSheet.Cells(row, col) = mValue
            End If
        Next col
        frmlookup.datPrimaryRS.MoveNext
        If frmlookup.datPrimaryRS.EOF() Then
             frmlookup.datPrimaryRS.MoveFirst
             Exit For
        End If
    Next row
        
    If IsFileThere(txtExcelTargetSpec) Then
         ' We have asked user earlier, so just delete it
         Kill txtExcelTargetSpec
    End If
    
    excelBook.SaveAs txtExcelTargetSpec
    
    excelApp.Quit
    Set excelSheet = Nothing
    Set excelBook = Nothing
    Set excelApp = Nothing
    
    Screen.MousePointer = vbDefault
    Lblprogressmsg.Visible = False
    Label1.Visible = True
    MsgBox "成功导出数据到 " & txtExcelTargetSpec
    Unload Me
    Exit Sub