如何在VB中实现将数据导出到Excel???

2002-02-09 06:49:07 161 阅读 AI 写同款 · GEO 优化AI 选题数据监测一键分发 ›

别再为数码管引脚发愁了！用STM32的普通IO口驱动TM1650数码管模块（附完整模拟I2C代码）本文详细介绍了如何利用STM32的普通IO口通过模拟I2C协议驱动TM1650数码管模块，提供了完整的硬件连接方案和软件实现代码。通过模拟I2C技术，开发者可以灵活使用任意GPIO引脚控制多位数码管显示，解决了传统驱动方式占用大量IO资源的问题。文章包含TM1650寄存器解析、亮度控制等实用功能实现，并分享了常见问题排查与性能优化技巧。阅读详情

用VB实现报表（报表使用Crystal报表），但是需要对这些报表中的数据加以保存
到Excel中，不知在VB中该如何实现？

...全文

避坑实录：用certificate-manager重置vCenter 6.7证书时遇到的三个致命陷阱本文详细解析了使用certificate-manager重置vCenter 6.7证书时可能遇到的三大致命陷阱，包括进度卡在85%的服务启动僵局、脚本突然退出的静默杀手以及密码错误锁死的隐藏机制。通过实战验证的解决方案和高级恢复技巧，帮助系统管理员有效避免vCenter环境瘫痪，确保证书更新过程顺利进行。阅读详情

lovepeacer

VB基础类 7,788 成员 197,583 内容

+ 关注 + 加入社区

切换为时间正序

lihonggen0 2002-03-05

打赏
举报

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1
' SSPanel2.Visible = True
' probar.Value = 0
' Dim myexcel As New Excel.Application, I, J, K As Integer, col As String
' With myexcel
' On Error GoTo excle
' .Application.Visible = False
' .Workbooks.Add
' '***********画字段************
' J = 0
' 'example: b2 ----g2 ’列本程序从b列,和第2行开始
' For I = 66 To (66 + Rs_temp.Fields.Count - 1) '从rs中头一个字段到最后一个
' col = Chr(I) & "2" 'chr(66)就是b
' Range(col).Select
' ActiveCell.FormulaR1C1 = Rs_temp.Fields(J).Name '
' J = J + 1
' Next I
' '*************以先横后竖顺序画表***************
' K = 0
' Rs_temp.MoveFirst
' DoEvents
' For J = 3 To 3 + Rs_temp.RecordCount '本程序从b3开始，所以用3
' K = 0
' For I = 66 To (66 + Rs_temp.Fields.Count - 1)
' col = Chr(I) & CStr(J) '得到目标表格的值如 c3
' Range(col).Select
' ActiveCell.FormulaR1C1 = Rs_temp.Fields(K)
' K = K + 1
' Next I
' On Error Resume Next
' probar.Value = probar.Value + 1
' Rs_temp.MoveNext
' If Rs_temp.EOF = True Then
' SSPanel2.Visible = False
' .Application.Visible = True
' End If
' Next J
' End With
'excle:
' MsgBox ("您没有安装excle2000，请先安装excel2000")

Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen1 As Integer
'存字段长度值
Dim Fieldlen()
'Dim xlApp As Excel.Application
'Dim xlBook As Excel.Workbook
'Dim xlSheet As Excel.Worksheet

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

SSPanel2.Visible = True
probar.Value = 0

'On Error GoTo excle
With Rs_temp
.MoveLast

If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Sub
End If

'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count

ReDim Fieldlen(Icolcount)
.MoveFirst

For Irow = 1 To Irowcount + 1

For Icol = 1 To Icolcount
Select Case Irow
'在Excel中的第一行加标题
Case 1
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name
'将数组FIELDLEN()存为第一条记录的字段长
Case 2
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
'如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
Else
Fieldlen(Icol) = LenB(.Fields(Icol - 1))
End If

xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
'Excel列宽等于字段长
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
'向Excel的CellS中写入字段值
Case Else
If IsNull(.Fields(Icol - 1)) Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
Else
Fieldlen1 = LenB(.Fields(Icol - 1))
End If

If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = IIf(Fieldlen1 > 255, 255, Fieldlen1)
'表格列宽等于较长字段长
Fieldlen(Icol) = IIf(Fieldlen1 > 255, 255, Fieldlen1)
'数组Fieldlen(Icol)中存放最大字段长度值
Else
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
End If

xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
End Select
Next

If Irow > 2 Then
If Not .EOF Then .MoveNext
End If

If Not .EOF Then
If Irow < Irowcount Then
probar.Value = probar.Value + 1
End If
End If

Next

'网格线
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With

'*!* 页眉、填报单位、报表时间、单位
With xlSheet.PageSetup
.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" ' & Gsmc
.CenterHeader = "&""楷体_GB2312,常规""业务数据综合查询表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日期："
.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
.LeftFooter = "&""楷体_GB2312,常规""&10制表人："
.CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
.RightFooter = "&""楷体_GB2312,常规""&10第&P页共&N页"
End With

'显示表格
Dim ExclFileName As String
ExclFileName = App.path & "\业务数据综合查询表.xls"
If Dir(ExclFileName) <> "" Then
Kill ExclFileName
End If
xlSheet.SaveAs (ExclFileName)
SSPanel2.Visible = False
xlApp.Application.Visible = True
'交还控制给Excel
'xlSheet.PrintPreview
'xlApp.Quit
End With
'excle:
' MsgBox ("您没有安装 Excle2000，请先安装 Excel2000 ！")
Case 2
Unload Me
End Select
End Sub

dbcontrols 2002-03-05

打赏
举报

'''''''''''''''''''''''''''''''''''''''''
' 整理：泰山 '
' 主页：http://dyqing.533.net '
' E-Mail:duyunqing@163.net '
'''''''''''''''''''''''''''''''''''''''''
'指定链接
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'Option Explicit
Dim x(1 To 4, 1 To 5) As Integer
Dim a, i, j As Integer
Dim b As String

Private Sub Command1_Click()
Dim ex As Object
Dim exbook As Object
Dim exsheet As Object
Set ex = CreateObject("Excel.Application")
Set exbook = ex.Workbooks().Add
Set exsheet = exbook.Worksheets("sheet1")
'按控件的内容赋值
'11
exsheet.Cells(1, 1).Value = Text1.Text
'为同行的几个格赋值
Range("C3").Select
ActiveCell.FormulaR1C1 = "表格"
' ex.Range("c3").Value = "表格"
ex.Range("d3").Value = " 春天 "
ex.Range("e3").Value = " 夏天 "
ex.Range("f3").Value = " 秋天 "
ex.Range("g3").Value = " 冬天 "
'大片赋值
ex.Range("c4:g7").Value = x
'按变量赋值
a = 8
b = "c" & Trim(Str(a))
ex.Range(b).Value = "下雪"
'另外一种大片赋值
For i = 9 To 12
For j = 4 To 7
exsheet.Cells(i, j).Value = i * j
Next j
Next i
'计算赋值
exsheet.Cells(13, 1).Formula = "=R9C4 + R9C5"
'设置字体
Dim exRange As Object
Set exRange = exsheet.Cells(13, 1)
exRange.Font.Bold = True

'设置一行为18号字体加黑
Rows("3:3").Select
Selection.Font.Bold = True
With Selection.Font
.Name = "宋体"
.Size = 18
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
'设置斜体
Range("E2").Select
Selection.Font.Italic = True
'设置下划线
Range("E3").Select
Selection.Font.Underline = xlUnderlineStyleSingle

'设置列宽为15
Selection.ColumnWidth = 15

'设置一片数据居中
Range("C4:G7").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
'设置某区域的小数位数
Range("F4:F7").Select
Selection.NumberFormatLocal = "0.00"

'求和
Range("G9:G13").Select
Range("G13").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
'某列自动缩放宽度
Columns("C:C").EntireColumn.AutoFit
'画表格
Range("C4:G7").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'加黑框
Range("C9:G13").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'设置某单元格格式为文本
Range("E11").Select
Selection.NumberFormatLocal = "@"
'设置单元格格式为数值
Range("F10").Select
Selection.NumberFormatLocal = "0.000_);(0.000)"
'设置单元格格式为时间
Range("F11").Select
Selection.NumberFormatLocal = "h:mm AM/PM"

'取消选择
Range("C10").Select
'设置横向打印，A4纸张
' With ActiveSheet.PageSetup
' .PrintTitleRows = ""
' .PrintTitleColumns = ""
' End With
' ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
' .LeftHeader = ""
' .CenterHeader = ""
' .RightHeader = ""
' .LeftFooter = ""
' .CenterFooter = ""
' .RightFooter = ""
' .LeftMargin = Application.InchesToPoints(0.75)
' .RightMargin = Application.InchesToPoints(0.75)
' .TopMargin = Application.InchesToPoints(1)
' .BottomMargin = Application.InchesToPoints(1)
' .HeaderMargin = Application.InchesToPoints(0.5)
' .FooterMargin = Application.InchesToPoints(0.5)
' .PrintHeadings = False
' .PrintGridlines = False
' .PrintComments = xlPrintNoComments
' .PrintQuality = 300
' .CenterHorizontally = False
' .CenterVertically = False
.Orientation = xlLandscape
' .Draft = False
.PaperSize = xlPaperA4
' .FirstPageNumber = xlAutomatic
' .Order = xlDownThenOver
' .BlackAndWhite = False
' .Zoom = 100
End With
'跨列居中
Range("A1:G1").Select
With Selection
.HorizontalAlignment = xlCenter
' .VerticalAlignment = xlBottom
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .ShrinkToFit = False
.MergeCells = True
End With
Selection.Merge

'打印表格
ActiveWindow.SelectedSheets.PrintOut Copies:=1

'取值
Text1.Text = exsheet.Cells(13, 1)
'保存
ChDir "C:\WINDOWS\Desktop"
ActiveWorkbook.SaveAs FileName:="C:\WINDOWS\Desktop\aaa.xls", FileFormat:=xlNormal, Password:="123", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False

' 关闭工作表。
exbook.Close
'用 Quit 方法关闭 Microsoft Excel
ex.Quit
'释放对象
Set ex = Nothing
Set exbook = Nothing
Set exsheet = Nothing
Dim retval
'用excel打开表格
retval = Shell("C:\Program Files\Microsoft Office\Office\EXCEL.EXE" & " " & "C:\WINDOWS\Desktop\aaa.xls", 1)

End Sub

Private Sub Form_Load()
Me.Show
End Sub

Private Sub Image2_Click()
'打开主页
ret& = ShellExecute(Me.hwnd, "Open", "http://dyqing.533.net", "", App.Path, 1)

End Sub

Private Sub Image1_Click()
'发送邮件
ret& = ShellExecute(Me.hwnd, "Open", "mailto:duyunqing@163.net", "", App.Path, 1)

End Sub

smarter 2002-03-05

打赏
举报

怎么在VB中设置Excel的行列值属性？

xiaomajia001 2002-03-02

打赏
举报

请问 cocoboy79(iThink.net)和icy_csdn() 二位大侠：把这个问题倒过来怎样将解决？
如有代码的话，请把它发到：“请cqq_chen大侠帮忙看看，拿分！”这个问题里，一样给分。
拜托。

dbcontrols 2002-03-02

打赏
举报

duyunqing@163.net
来信要代码

ywys 2002-03-02

打赏
举报

lovepeacer 2002-02-10

打赏
举报

那如何把报表的表头也在EXCEL中显示，格式也一样！

michaelpeng7799 2002-02-10

打赏
举报

??? 这里一粘中文怎么全变成;ÎÄ¼þÎª
了??

我的EMAIL:cocoboy79@163.com
EMAIL得了.

michaelpeng7799 2002-02-10

打赏
举报

楼上的方面也行,按行倒,不过数据多了,会慢.
oledb provider for ject4提供数据导出的功能.
我这里完整的程序,你要EMAIL我,我再发过去.
下面是代码,其实你看看重要的几句就行了.

Dim Export_Str, mdbTable As String
Dim rsExport As New ADODB.Recordset
Dim conn As New ADODB.Connection
Private Sub Close_cmd_Click()
Unload Me
End Sub

Private Sub EXport_cmd_Click()
Dim myPath, myStr As String, myPos As Integer

'******************´¦ÀíÑ¡ÔñµÄ¸÷ÖÖ±íµÄµ¼³ö
With Dialog1
If myOption(2).Value Then
.FilterIndex = 1
.ShowSave
myStr = StrReverse(.FileName) '´®È¡·´
myPos = InStr(myStr, "\") 'ÔÚ·´×Ö·û´®ÖÐ£¬ÕÒ´Ó×ó¿ªÊ¼µÚÒ»¸ö\µÄÎ»ÖÃ
On Error GoTo myError '·ÀFILENAMEÎª¿Õ£¬MID³ö´í
myPath = StrReverse(Mid(myStr, myPos)) 'È¡Ä¿Â¼²¿·Ö£¬²¢»¹Ô.
myStr = StrReverse(Left(myStr, myPos - 1)) 'È¡ÎÄ¼þÃû
Export_Str = "select * into [dBase III;database=" & myPath & "]." & myStr & " from Customers"
.DefaultExt = "*.DBF"

ElseIf myOption(3).Value Then
mdbTable = InputBox("Çë¸øµ¼³öµ½MDBÎÄ¼þµÄ±íÈ·¶¨±íÃû")
.FilterIndex = 2
.ShowSave
Export_Str = "select * into [;database=" & .FileName & "]." & mdbTable & " from Customers"
.DefaultExt = "*.MDB"

ElseIf myOption(4).Value Then
.FilterIndex = 3
.ShowSave
Export_Str = "select * into [Excel 8.0;database=" & .FileName & "].Customers from Customers"
.DefaultExt = "*.XLS"

ElseIf myOption(5).Value Then
.FilterIndex = 4
.ShowSave
myStr = StrReverse(.FileName) '´®È¡·´
myPos = InStr(myStr, "\") 'ÔÚ·´×Ö·û´®ÖÐ£¬ÕÒ´Ó×ó¿ªÊ¼µÚÒ»¸ö\µÄÎ»ÖÃ
On Error GoTo myError '·ÀFILENAMEÎª¿Õ£¬MID³ö´í
myPath = StrReverse(Mid(myStr, myPos)) 'È¡Ä¿Â¼²¿·Ö£¬²¢»¹Ô.
myStr = StrReverse(Left(myStr, myPos - 1)) 'È¡ÎÄ¼þÃû
Export_Str = "select * into [Paradox 4.X;database=" & myPath & "]." & myStr & " from Customers"
.DefaultExt = "*.DB"
End If
End With

'*****Éú³ÉÎÄ¼þ
Debug.Print Export_Str
If rsExport.State = 1 Then
rsExport.Close
End If

If Dir(Dialog1.FileName) <> "" Then
On Error GoTo myError '·ÀÓÃ»§Ã»Ñ¡ÎÄ¼þ
If Dialog1.FilterIndex <> 2 Then
Kill (Dialog1.FileName)
End If
rsExport.Open Export_Str, conn, adOpenStatic, adLockOptimistic
Else
rsExport.Open Export_Str, conn, adOpenStatic, adLockOptimistic
End If
myError:
Exit Sub
End Sub

Private Sub Form_Load()
'Áª½ÓÊý¾Ý¿â²¢´ò¿ª¼ÇÂ¼¼¯
conn.CursorLocation = adUseServer
conn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "\NWind.mdb;"
rsExport.Open "select *from Customers", conn, adOpenStatic, adLockOptimistic
Set Grid1.DataSource = rsExport

'³õÊ¼»¯¶Ô»°¿ð
With Dialog1
.Filter = "FoxBase/FoxPro (*.DBF)|*.DBF|Access 8.0(*.MDB)|*.MDB|Excel 8.0(*.XLS)|*.XLS|Paradox 4.x(*.DB)|*.DB"
.DialogTitle = "µ¼³öÎÄ¼þÎª"
.CancelError = False
End With
End Sub

icy_csdn 2002-02-09

打赏
举报

Dim tempxlApp As New Excel.Application
Dim tempxlWorkbook As New Excel.Workbook
Dim tempxlSheet As New Excel.Worksheet

Set tempxlWorkbook = tempxlApp.Workbooks.Open("e:\test.xls")
tempxlApp.Visible = True
tempxlApp.DisplayAlerts = False
set tempxlSheet = tempxlWorkbook.Worksheets("sheet1")

'写入Excel
tempxlSheet.Range("A1").CopyFromRecordset tempRS
tempRS.Close
tempRS 为记录集
希望对你有所帮助！！！

如何在VB中实现将数据导出到Excel???

相关推荐