将数组值写入Excel的快速方法

DawnPine 2005-08-09 08:44:33
除了用循环一个个cell地写
还有哪些高效方法?
...全文
927 点赞 收藏 12
写回复
12 条回复
切换为时间正序
请发表友善的回复…
发表回复
titihao 2005-08-11
“把数组是Variant变量,rang变量区域与数组大小相当,两者就可以直接相互赋值”

确实如此,如果不通过这个方式,而利用循环实在是在太慢了,呵呵,,用这个赋值的时间基本可以忽略不计呀,,在处理大量的数据的时候确实是很有用呀,

回复
loverpyh 2005-08-09
End With
With objExcelWorkSheet

For i = 1 To lngCols
'Debug.Print arrType(i)
Select Case arrType(i - 1)
Case dtString
.Range(.Cells(1, i), .Cells(lngRows + 2, i)).NumberFormatLocal = "@" '¸ñʽ»¯Îª×Ö·û´®ÀàÐÍ
' Case dtDate
' .Range(.Cells(1, i), .Cells(lngRows + 2, i)).NumberFormatLocal = "yyyy-mm-dd" '¸ñʽ»¯Îª×Ö·û´®ÀàÐÍ
' Case dtNumber
' .Range(.Cells(1, i), .Cells(lngRows + 2, i)).NumberFormatLocal = "0.00_ " '¸ñʽ»¯ÎªÊý×ÖÀàÐÍ
End Select
Next
'"0." & String(intDot, "0") & "_ "
'.Range(.Cells(1, 1), .Cells(UBound(arrTemp, 1) + 1, UBound(arrTemp, 2) + 1)).NumberFormatLocal = "@"
.Range(.Cells(1, 1), .Cells(UBound(arrTemp, 1) + 1, UBound(arrTemp, 2) + 1)) = arrTemp 'дÈëexcel

End With

objExcelWorkBook.SaveAs FileName:= _
strExcelPath, FileFormat:= _
1, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
objExcelApp.Quit

Set objExcelApp = Nothing
Set objExcelWorkBook = Nothing
Set objExcelWorkSheet = Nothing
GridToExcel = True
Screen.MousePointer = 0
objInterCont.Tips "µ¼³öÊý¾Ý³É¹¦!"
Exit Function
errHandle:
GridToExcel = False
Set objExcelApp = Nothing
Set objExcelWorkBook = Nothing
Set objExcelWorkSheet = Nothing
Screen.MousePointer = 0
If Err.Number = 75 Then
objInterCont.Tips "Ëù¸²¸ÇµÄExcelÎļþÊôÐÔÖ»¶Á,µ¼³öʧ°Ü!"
Exit Function
End If
If Err.Number = 70 Then
objInterCont.Tips "Ëù¸²¸ÇµÄExcelÎļþÒÑ´ò¿ª,µ¼³öʧ°Ü!"
Exit Function
End If
mobjErrLog.Record Err.Number, Err.Description, "DataOperator.cls", "GridToExcel"
End Function
回复
loverpyh 2005-08-09
'Íø¸ñÄÚÈݵ¼³öµ½excel
Public Function GridToExcel(objGrid As Object) As Boolean

Dim i As Long
Dim j As Long
Dim intCol As Integer
Dim strExcelPath As String 'µ¼³öµÄexcelÎļþ·¾¶
Dim arrTemp() As Variant
'µ¼³öµ½excelÿÁеÄÊý¾ÝÀàÐÍ
Dim arrType() As gDataType

Dim lngRows As Long
Dim lngCols As Long
Dim objExcelApp As Object
Dim objExcelWorkBook As Object
Dim objExcelWorkSheet As Object

If objGrid.Rows = 1 Then objInterCont.Tips "Íø¸ñÖÐûÓÐÒªµ¼³öµÄÊý¾Ý!": Exit Function
If CheckExcel = False Then objInterCont.Tips "ÇëÈ·¶¨ÒÑÕýÈ·°²×°ÁËExcelÈí¼þ!": Exit Function
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Visible = False
On Error GoTo errHandle
Err.Clear
With frmReport.dlgExport '´ò¿ª±£´æ¶Ô»°¿ò
.FileName = ""
.DialogTitle = "ÇëÊäÈëexcelÃû³Æ"

.Filter = "Excel Files(*.xls)|*.xls" 'ÎļþÀàÐ͹ýÂÇΪexcel
.ShowSave
If Trim(.FileName) = "" Then Exit Function
strExcelPath = Trim(.FileName)
If Dir(Trim(.FileName)) <> "" Then 'Èç¹û´æÔÚÎļþÔòÌáʾ
If MsgBox("ÎļþÒÑ´æÔÚ,ÊÇ·ñÌæ»»Ô­Îļþ?", vbYesNo + vbQuestion, "Ìáʾ") = vbYes Then
Kill Trim(.FileName)
Else
Exit Function
End If
End If
End With
Screen.MousePointer = 11
DoEvents
Set objExcelWorkBook = objExcelApp.Workbooks.Add
Set objExcelWorkSheet = objExcelWorkBook.Worksheets(1) 'дÈëµÚÒ»¸ö¹¤×÷²¾

With objGrid
intCol = 0

For i = 0 To .Cols - 1
If .ColHidden(i) = False Then
ReDim Preserve arrType(intCol)
'======¼Ç¼Íø¸ñ¸÷ÁеÄÊý¾ÝÀàÐÍ============================================
Select Case .ColDataType(i)
'×Ö·û´®ÀàÐÍ(²¼¶ûÐÍ×÷Ϊ×Ö·û´®,ÒòΪ²¼¶ûÐ͵¼³öºóΪ'ÊÇ','·ñ',)
Case flexDTBoolean, flexDTString, flexDTStringC, flexDTStringW, 130
arrType(intCol) = dtString
Case flexDTCurrency, flexDTDecimal, flexDTDouble, flexDTLong, flexDTLong8, flexDTSingle, 131
arrType(intCol) = dtNumber
Case flexDTDate
arrType(intCol) = dtDate
Case Else
arrType(intCol) = dtOther
End Select
intCol = intCol + 1 '¼ÆËãδ±»Òþ²ØµÄÍø¸ñÁÐÊý
End If
Next
'-----Íø¸ñ¿É¼ûµÄÁÐÊý-----------
lngCols = intCol
'-----Íø¸ñÐÐÊý-----------------
lngRows = .Rows - 1

ReDim arrTemp(lngRows, lngCols - 1)

'===========±£´æÍø¸ñÊý¾Ýµ½ÁÙʱÊý×é===============================================
For i = 0 To .Rows - 1
intCol = 0
For j = 0 To .Cols - 1
If .ColHidden(j) = False Then
'ÊDz¼¶ûÐÍÏÔʾΪÊÇ»òÕß·ñ i>0±íʾ±êÌâÀ¼²»×öÒÔÏ´¦Àí
If .ColDataType(j) = flexDTBoolean And i > 0 Then
If Trim(.TextMatrix(i, j)) = "-1" Then
arrTemp(i, intCol) = "ÊÇ"
Else
arrTemp(i, intCol) = "·ñ"
End If
Else
arrTemp(i, intCol) = .TextMatrix(i, j) '°ÑÍø¸ñÊý¾Ý±£´æµ½Êý×é
End If

intCol = intCol + 1

End If
Next
If i Mod 20 = 0 Then DoEvents
Next


回复
DawnPine 2005-08-09
大家可否附带讨论一下从Excel读数据到数组的方法?
回复
sdrcxzy 2005-08-09
of123() 帅啊 ……
蹭分……
回复
of123 2005-08-09
Excel 的 Automation 可以直接将数组数据转换到一个 Range 中:

Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object

'Start a new workbook in Excel
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add

'Create an array with 3 columns and 100 rows
Dim DataArray(1 To 100, 1 To 3) As Variant
Dim r As Integer
For r = 1 To 100
DataArray(r, 1) = "ORD" & Format(r, "0000")
DataArray(r, 2) = Rnd() * 1000
DataArray(r, 3) = DataArray(r, 2) * 0.7
Next

'Add headers to the worksheet on row 1
Set oSheet = oBook.Worksheets(1)
oSheet.Range("A1:C1").Value = Array("Order ID", "Amount", "Tax")

'Transfer the array to the worksheet starting at cell A2
oSheet.Range("A2").Resize(100, 3).Value = DataArray

'Save the Workbook and Quit Excel
oBook.SaveAs "C:\Book1.xls"
oExcel.Quit
回复
xiaonian_3654 2005-08-09
循环很慢么?
回复
maweifeng 2005-08-09
http://maweifeng.cnblogs.com/archive/2005/06/28/182483.aspx
回复
wangguan007 2005-08-09
学习啊!
回复
DawnPine 2005-08-09
回 xiaonian_3654(你猜猜(我要打光棍,小乔嫁不了))
循环确实慢, 如果你有几十列 上万条数据就更不得了了

感谢of123
确实是个好方法!

回龙行天下: 你的代码好深奥 不大看得明白 :-(

回gowowo(): 示例简洁, 效果不错! 谢谢!!
回复
xinliangyu 2005-08-09
该贴子对规模读\写Excel工作表的讨论已相当完备了。
回复
gowowo 2005-08-09
把数组是Variant变量,rang变量区域与数组大小相当,两者就可以直接相互赋值
Sub aa()
Dim A As Variant, R As Range, N1 As Long, N2 As Long
N1 = 3
N2 = 10
ReDim A(1 To N1, 1 To N2)
For L1 = 1 To N1
For L2 = 1 To N2
A(L1, L2) = L1 & "行" & L2 & "列"
Next
Next
Set R = Range(Cells(1, 1), Cells(N1, N2))
'A ,R 之间就可以直接相互赋值
R = A '数组读到EXCEL
A = R 'EXCEL读到数组
End Sub
回复
发动态
发帖子
VBA
创建于2007-09-28

2026

社区成员

VBA(Visual Basic for Applications)是Visual Basic的一种宏语言,是在其桌面应用程序中执行通用的自动化(OLE)任务的编程语言。
申请成为版主
社区公告
暂无公告