Public Sub OutDataToExcel(Flex As MSFlexGrid) Dim s As String Dim i As Integer Dim j As Integer Dim k As Integer Dim x As Integer Dim Hang As String Hang = "f" On Error GoTo Ert FrmJinDuTiao.MousePointer = 11 FrmJinDuTiao.Show Dim Excelapp As Excel.Application Set Excelapp = New Excel.Application On Error Resume Next DoEvents Excelapp.SheetsInNewWorkbook = 1 Excelapp.Workbooks.Add Excelapp.ActiveSheet.Cells(1, 3) = s Excelapp.Range("D1:D8").Width = 10000 Excelapp.Selection.Font.FontStyle = "Bold" Excelapp.Selection.FontSize = 6 Select Case Flex.Cols Case 1: Hang = "A" Case 2: Hang = "B" Case 3: Hang = "C" Case 4: Hang = "D" Case 5: Hang = "E" Case 6: Hang = "F" Case 7: Hang = "G" Case 8: Hang = "H" Case 9: Hang = "I" Case 10: Hang = "J" Case 11: Hang = "K" Case 12: Hang = "L" Case 13: Hang = "M" Case 14: Hang = "N" Case 15: Hang = "O" Case 16: Hang = "P" Case 17: Hang = "Q" Case 18: Hang = "R" Case 19: Hang = "S" Case 20: Hang = "U"
End Select With Flex k = .Rows With Excelapp.ActiveSheet.Range("a3:" & Hang & .Rows + 2).Borders '边框设置
.LineStyle = 1 'xlBorderLineStyleContinuous
.Weight = xlThin
.ColorIndex = 1
End With Excelapp.ActiveSheet.Range("a3:" & Hang & .Rows + 2).Font.Size = 9 'xlBorderLineStyleContinuous For i = 0 To k - 1 For j = 0 To .Cols - 1 FrmJinDuTiao.JinDu.Value = FrmJinDuTiao.JinDu.Value + 1 If FrmJinDuTiao.JinDu.Value = 100 Then FrmJinDuTiao.JinDu.Value = FrmJinDuTiao.JinDu.Value - 100 End If DoEvents Excelapp.ActiveSheet.Cells(3 + i, j + 1) = "'" & .TextMatrix(i, j) Next j Next i End With FrmJinDuTiao.MousePointer = 0 Unload FrmJinDuTiao Excelapp.Visible = True Excelapp.Sheets.PrintPreview
Exit Sub Ert: If Not (Excelapp Is Nothing) Then Excelapp.Quit End If end sub
Public Function ExporToExcel(strOpen As String) '********************************************************* '* 名称：ExporToExcel '* 功能：导出数据到EXCEL '* 用法：ExporToExcel(sql查询字符串) '********************************************************* Dim Rs_Data As New ADODB.Recordset Dim Irowcount As Integer Dim Icolcount As Integer Dim cn As New ADODB.Connection Dim xlApp As New Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim xlQuery As Excel.QueryTable With Rs_Data If .State = adStateOpen Then .Close End If .ActiveConnection = "provider=msdasql;DRIVER=Microsoft Visual FoxPro Driver;UID=;Deleted=yes;Null=no;Collate=Machine;BackgroundFetch=no;Exclusive=No;SourceType=DBF;SourceDB=D:\DBF;" .CursorLocation = adUseClient .CursorType = adOpenStatic .Source = strOpen .Open End With With Rs_Data If .RecordCount < 1 Then MsgBox ("没有记录!") Exit Function End If '记录总数 Irowcount = .RecordCount '字段总数 Icolcount = .Fields.Count End With
Set xlApp = CreateObject("Excel.Application") Set xlBook = Nothing Set xlSheet = Nothing Set xlBook = xlApp.Workbooks().Add Set xlSheet = xlBook.Worksheets("sheet1") xlApp.Visible = True
'添加查询语句，导入EXCEL数据 Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
xlQuery.FieldNames = True '显示字段名 xlQuery.Refresh
xlApp.Application.Visible = True Set xlApp = Nothing '"交还控制给Excel Set xlBook = Nothing Set xlSheet = Nothing
VB中如何将MSFlexGrid数据导入到Excel中??
如何用VB 设计Excel表格?当中的空格栏怎么合并??
---------------------------------
单位名称 ¦ 单位数 ¦
-------- ¦-------- ¦---------------
私有企业 ¦企业一 ¦
¦企业二 ¦
¦企业三 ¦
---------------------------------
国有企业 ¦企业一 ¦
¦企业二 ¦
¦企业三 ¦
---------------------------------
---------------------------------------------------------------
'导出至Excel
Public Sub OutDataToExcel(Flex As MSFlexGrid)
Dim s As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim x As Integer
Dim Hang As String
Hang = "f"
On Error GoTo Ert
FrmJinDuTiao.MousePointer = 11
FrmJinDuTiao.Show
Dim Excelapp As Excel.Application
Set Excelapp = New Excel.Application
On Error Resume Next
DoEvents
Excelapp.SheetsInNewWorkbook = 1
Excelapp.Workbooks.Add
Excelapp.ActiveSheet.Cells(1, 3) = s
Excelapp.Range("D1:D8").Width = 10000
Excelapp.Selection.Font.FontStyle = "Bold"
Excelapp.Selection.FontSize = 6
Select Case Flex.Cols
Case 1:
Hang = "A"
Case 2:
Hang = "B"
Case 3:
Hang = "C"
Case 4:
Hang = "D"
Case 5:
Hang = "E"
Case 6:
Hang = "F"
Case 7:
Hang = "G"
Case 8:
Hang = "H"
Case 9:
Hang = "I"
Case 10:
Hang = "J"
Case 11:
Hang = "K"
Case 12:
Hang = "L"
Case 13:
Hang = "M"
Case 14:
Hang = "N"
Case 15:
Hang = "O"
Case 16:
Hang = "P"
Case 17:
Hang = "Q"
Case 18:
Hang = "R"
Case 19:
Hang = "S"
Case 20:
Hang = "U"
End Select
With Flex
k = .Rows
With Excelapp.ActiveSheet.Range("a3:" & Hang & .Rows + 2).Borders '边框设置
.LineStyle = 1 'xlBorderLineStyleContinuous
.Weight = xlThin
.ColorIndex = 1
End With
Excelapp.ActiveSheet.Range("a3:" & Hang & .Rows + 2).Font.Size = 9 'xlBorderLineStyleContinuous
For i = 0 To k - 1
For j = 0 To .Cols - 1
FrmJinDuTiao.JinDu.Value = FrmJinDuTiao.JinDu.Value + 1
If FrmJinDuTiao.JinDu.Value = 100 Then
FrmJinDuTiao.JinDu.Value = FrmJinDuTiao.JinDu.Value - 100
End If
DoEvents
Excelapp.ActiveSheet.Cells(3 + i, j + 1) = "'" & .TextMatrix(i, j)
Next j
Next i
End With
FrmJinDuTiao.MousePointer = 0
Unload FrmJinDuTiao
Excelapp.Visible = True
Excelapp.Sheets.PrintPreview
Exit Sub
Ert:
If Not (Excelapp Is Nothing) Then
Excelapp.Quit
End If
end sub
---------------------------------------------------------------
把记录集导出到Excel，引用自小马哥
Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim cn As New ADODB.Connection
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = "provider=msdasql;DRIVER=Microsoft Visual FoxPro Driver;UID=;Deleted=yes;Null=no;Collate=Machine;BackgroundFetch=no;Exclusive=No;SourceType=DBF;SourceDB=D:\DBF;"
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
End Function
---------------------------------------------------------------