怎样把数据导到Excel表里？

2006-12-15 03:30:50 301 阅读 AI 写同款 · GEO 优化AI 选题数据监测一键分发 ›

智能医疗新篇章：YOLOv8在肺炎诊断中的性能优化与挑战本文探讨了YOLOv8在肺炎诊断中的性能优化与挑战，展示了其在医疗影像分析中的卓越表现，包括92.3%的mAP准确率和23ms的快速推理速度。通过数据增强、模型架构定制和训练策略优化，显著提升了诊断效率。同时，文章深入分析了小样本学习、实时性平衡及模型可解释性等关键挑战，为智能医疗应用提供了实践指南。阅读详情

怎样把recordset里的数据导入到有固定格式的Excel里
Excel样式是预先设计好的

...全文

基于YOLOv8和CNN的肺炎X光片智能诊断系统深度学习在医疗影像分析领域展现出巨大潜力，特别是卷积神经网络(CNN)和目标检测模型如YOLOv8的结合应用。这些技术通过自动提取图像特征，显著提升了肺炎等疾病的诊断效率和准确性。在工程实践中，多模型对比架构和端到端训练流程是关键创新点，ResNet50等模型在验证集上达到92.3%的准确率。这类系统特别适用于基层医疗机构和突发公共卫生事件，能够实现秒级初筛，大幅减轻放射科医生的工作负担。通过PySide6框架开发的可视化GUI界面，使得深度学习模型的部署和应用更加便捷，为临床决策提供了可靠支持。阅读详情

jilong4

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

+ 关注 + 加入社区

切换为时间正序

ap0106204 2006-12-15

打赏
举报

保存

carfield2003 2006-12-15

打赏
举报

http://blog.csdn.net/tt528/archive/2006/11/20/1398645.aspx

蔡健常熟 2006-12-15

打赏
举报

'引用 microsoft excel 9.0 object library 以上版本
'调用 call ExportToExcel(adodc1.recordset,"表格名称")或call ExportToExcel(ADODB.Recordset,"表格名称")
'如果是ADODB.Recordset 传递数据集，需要使用用户游标 rs.CursorLocation = adUseClient

Public Function ExportToExcel(Rs_Data As ADODB.Recordset, Titles_Name)
On Error GoTo ERRCL
Dim Irowcount As Long
Dim Icolcount As Long

Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable

' 假设rs_data是你的记录集
If Rs_Data.RecordCount < 1 Then
MsgBox "没有可导出的记录!", vbInformation + vbOKOnly, "提示"
Exit Function
End If
'记录总数
Irowcount = Rs_Data.RecordCount
'字段总数
Icolcount = Rs_Data.Fields.Count

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("a2"))
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 8)).Merge
xlSheet.Cells(1, 1).HorizontalAlignment = xlCenter
xlSheet.Cells(1, 1) = Titles_Name
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With

xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "宋体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(2, 1), .Cells(Irowcount + 2, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式

' .PageSetup.PaperSize = xlPaperA4 '
' .PageSetup.PrintGridlines = True
End With
xlApp.Application.Visible = True

Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Function
ERRCL: MsgBox "无有效数据或 Excel 2000 未安装！", vbInformation, "错误"
End Function

zq972 2006-12-15

打赏
举报

在程序中引用Microsoft Excel 9.0 Object Library，将下文加入到一个模块中,窗体中调用如下ExporToExcel("select * from table")。则实现快速将数据导出到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 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 = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.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"))

With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With

xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh

With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).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

xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
End Function

注:：在程序中引用'Microsoft Excel 9.0 Object Library'和ADO对象,机器必装Excel 2000
本程序在Windows 98/2000,VB 6 下运行通过。

cangwu_lee 2006-12-15

打赏
举报

自己挑一下，意思应该是完整的。有个别函数，你就重新写或者换成VB自带的函数。

Public Sub doExport(ByVal caption As String, ByVal text As String, ByVal MsgHwnd As Long, _
ByVal grid As DataGrid, _
ByVal rs As ADODB.Recordset)
If UCase(TypeName(rs)) = "Nothing" Then
Exit Sub
End If

If rs.Fields.Count = 0 Or grid.Columns.Count = 0 Then
Exit Sub
End If

Dim Fn As String

Fn = FileDialog.SaveDialog(MsgHwnd)
If Fn = "" Then Exit Sub
If Not EndWith(Fn, ".xls") Then Fn = Fn & ".xls"

Dim xls As Excel.Application
Dim w As Excel.Workbook
Dim e As Excel.Worksheet

Screen.MousePointer = 11
On Error Resume Next
Set xls = CreateObject("Excel.Application")
If Err.Number <> 0 Then
MsgBox "Sorry, create Excel object exception. Please check if Excel installed."
Exit Sub
End If
On Error GoTo 0
xls.Visible = True
If fileExists(Fn) Then
Set w = xls.Workbooks.Open(Fn)
Else
Set w = xls.Workbooks.Add()
End If

Set e = w.Worksheets.Add()

Dim line As Long, iP As Integer
line = 1

If caption <> "" Then
e.cells(line, grid.Columns.Count / 2) = caption
line=line+1
End If

If text <> "" Then
If grid.Columns.Count > 2 Then
e.cells(line, CInt(grid.Columns.Count / 2) - 1) = text
Else
e.cells(line, grid.Columns.Count / 2) = text
End If
line=line+1
End If

For iP = 0 To grid.Columns.Count - 1
e.cells(line, 1 + iP) = grid.Columns(iP).caption
Next iP
Call inc(line)

If Not (rs.EOF And rs.BOF) Then
Dim bm As Long
bm = rs.Bookmark
rs.MoveFirst
Do While Not rs.EOF
e.cells(line, 1) = rs.Fields("PName").value
e.cells(line, 2) = rs.Fields("PAge").value
e.cells(line, 3) = rs.Fields("PGender").value
e.cells(line, 4) = rs.Fields("PPhone").value
e.cells(line, 5) = rs.Fields("PContent").value
e.cells(line, 6) = rs.Fields("FinishDT").value
e.cells(line, 7) = rs.Fields("FinishBy").value
e.cells(line, 8) = rs.Fields("PResult").value
e.cells(line, 9) = rs.Fields("Remark1").value
e.cells(line, 10) = rs.Fields("Remark2").value
line=line+1
rs.MoveNext
Loop
On Error Resume Next
rs.MoveFirst
If rs.Bookmark <> bm Then rs.Bookmark = bm
End If

e.Range("A1", "Z" & line).Columns.AutoFit
On Error GoTo 0

xls.DisplayAlerts = False
If fileExists(Fn) Then w.Save Else w.SaveAs Fn

w.Close
xls.Quit
Sleep 300

Set w = Nothing
Set xls = Nothing
Screen.MousePointer = 0
End Sub

怎样把数据导到Excel表里？

相关推荐