在VBA中将不规则数据导出到Excel

最新推荐文章于 2020-12-06 12:42:40 发布

eclipse_xu

最新推荐文章于 2020-12-06 12:42:40 发布

阅读量2.1k

点赞数 1

分类专栏： VBA

本文链接：https://blog.csdn.net/eclipsexys/article/details/8209429

版权

VBA 专栏收录该内容

10 篇文章 0 订阅

订阅专栏

在Access中将数据导出到Excel非常简单，我们只要将查询出的RecordSet用循环或者固定格子的方式写到Excel中即可。下面是一个小例子：

Private Function F_Export() As Boolean
    Dim cnCurrent1 As ADODB.Connection
    Dim rcdTemp1 As ADODB.Recordset
    Dim ExcelApp
    Dim ExcelWorkBook
    Dim ExcelWorkSheet
    
    Dim NetNum As Integer
    Dim NetSum As Double
    Dim TNum As Integer
    Dim TSum As Double
    Dim Side As String
    
On Error GoTo ErrHandle
    F_T1SumExport = False
    
    Set cnCurrent1 = CurrentProject.Connection
    Set rcdTemp1 = New ADODB.Recordset
    
    Dim querySql1 As String
    NetSum = 0
    querySql1 = "S   Q   L"
    rcdTemp1.Open querySql1, cnCurrent1, adOpenKeyset
    If rcdTemp1.RecordCount > 0 Then
        NetNum = rcdTemp1.RecordCount
        rcdTemp1.MoveFirst
        Do While Not rcdTemp1.EOF
	   '
           ‘do sth
	   '
        rcdTemp1.MoveNext
        Loop
    End If
    rcdTemp1.Close
    Set rcdTemp1 = Nothing
    Set cnCurrent1 = Nothing
    
    Set ExcelApp = CreateObject("Excel.Application")
    ExcelApp.Visible = True
    
    Set ExcelWorkBook = ExcelApp.WorkBooks.Add()
    Set ExcelWorkSheet = ExcelWorkBook.WorkSheets(1)

    '设置标题单元格字体颜色大小
    ExcelWorkSheet.Range("A1").Select
    With ExcelApp.Selection
    .Font.Name = "Arial Unicode MS"
    .Font.Size = "12"
    .Font.Bold = True
    End With
    
    '设置正文单元格字体颜色大小
    ExcelWorkSheet.Range("A2:F11").Select
    With ExcelApp.Selection
    .Font.Name = "Arial Unicode MS"
    .Font.Size = "10"
   '.Font.ColorIndex = 5
    End With
    
    '设置边框
    ExcelWorkSheet.Range("A6:C9").Select
    With ExcelApp.Selection.Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    '.ColorIndex = 5
    End With

    ExcelWorkSheet.Cells(1, 1) = "s     t     h"
    
    '写数据到Excel
    ExcelWorkSheet.Cells(3, 4) = Me.txt_date1.Value
    ExcelWorkSheet.Cells(7, 2) = NetNum
   
    '合并单元格
    'D = "A" + CStr(1 + 4 + 1) + ":C" + CStr(1 + 4 + 1)
        'ExcelWorkSheet.Range(D).Select
        'With ExcelApp.Selection
        '.VerticalAlignment = -4108
        '.Orientation = 0
        '.AddIndent = False
        '.IndentLevel = 0
        '.ShrinkToFit = False
        '.MergeCells = True
        'End With
    
    F_Export = True
    
On Error GoTo 0
    Exit Function

ErrHandle:
    MsgBox Error(Err), vbExclamation
End Function