'将数据导入到excel worksheet中,先将数据保存在数组中,然后一次性导入worksheet,速度提高无数倍(没算过 :)
'If the function run successfully then return true else return false
'Parameter:
'StartingCell: The position of the Starting cell
'WriteHeader:if true, write the field name, else do not write it
Private Function CopyRecords(RST As ADODB.Recordset, WS As Worksheet, _
StartingCell As ExlCell, WriteHeader As Boolean) As Boolean
Dim SomeArray() As Variant
Dim Row As Long
Dim Col As Long
Dim Fd As ADODB.Field
Dim Recs As Long 'Recordcount
Dim iBeginRow As Integer 'In SomeArray,the begin row of the real data,not header
Dim Counter As Integer, i As Integer
On Error GoTo Err_CopyRecords
'check if recordset is opened
If RST.State <> adStateOpen Then GoTo Err_CopyRecords
' check if recordset is not empty
If RST.EOF And RST.BOF Then GoTo Err_CopyRecords
RST.MoveLast
ReDim SomeArray(0 To RST.RecordCount + 1, 0 To RST.Fields.Count)
iBeginRow = 0
If WriteHeader = True Then
' copy column headers to array
Col = 0
For Each Fd In RST.Fields
SomeArray(0, Col) = Fd.Name
Col = Col + 1
Next
iBeginRow = 1
End If
' copy recordset to SomeArray
RST.MoveFirst
Recs = RST.RecordCount
Counter = 0
For Row = iBeginRow To Recs - 1 + iBeginRow
Counter = Counter + 1
If Counter <= Recs Then i = (Counter / Recs) * 100
For Col = 0 To RST.Fields.Count - 1
SomeArray(Row, Col) = RST.Fields(Col).Value
If IsNull(SomeArray(Row, Col)) Then _
SomeArray(Row, Col) = ""
Next
RST.MoveNext
Next
' The range should have the same number of
' rows and cols as in the recordset
WS.Range(WS.Cells(StartingCell.Row, StartingCell.Col), _
WS.Cells(StartingCell.Row + RST.RecordCount + 1, _
StartingCell.Col + RST.Fields.Count)).Value = SomeArray