同样方法操作，速度相差很多 - Office中国论坛/Access中国论坛

Sub CMDPRINT_Click()
CurrentDb.Execute "delete * from 表_调拨明细"
t = Timer
CurrentDb.Execute "INSERT INTO 表_调拨明细( 流水号, 调拨明细 ) SELECT 表_指令调拨表.流水号, " & _
"DMerge('调出单号 & 半成品数量 & 备注','表_指令调拨表','流水号=' & [流水号] & '',',') " & _
" FROM 表_指令调拨表 GROUP BY 流水号 ORDER BY 流水号"
MsgBox "秏时: " & Timer - t & " 秒"
End Sub
Public Function DMerge(Exps As String, Domain As String, _
Optional Criteria As String, Optional Separator As String = ";") As String
'函数功能：合并指定记录集指定字段值为一个字符串
'参数说明：
' expr : 要合并的字段
' domain : 来源表或查询
' criteria : 可选,限制记录的条件表达式
' Separator : 可选,合并记录的分隔符,默认为分号(;)
'
'调用示例： DMerge("姓名","人员表","性别='" & [性别] & "'",Chr(13) & Chr(10))
' 以上示例在查询中，使用了换行分隔符，返回换行显示的姓名
'作者： t小雨
'创建时间： 2009/11/25
On Error Resume Next
Dim rst As New ADODB.Recordset
Dim strSql As String
strSql = "Select " & Exps & " From " & Domain
If Criteria <> "" Then strSql = strSql & " Where " & Criteria
rst.Open strSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly, adCmdText
If Not rst.EOF Then DMerge = rst.GetString(adClipString, , , Separator)
rst.Close
Set rst = Nothing
End Function

复制代码

Sub macro2()
Dim arr2()
Dim i As Integer
Dim a As Integer
Dim s As String
Dim e As Double
Dim rs As ADODB.Recordset
CurrentDb.Execute "delete * from 表_调拨明细"
e = Timer
arr2 = CurrentProject.Connection.Execute("SELECT * FROM 表_指令调拨表 order by 流水号").getrows
a = UBound(arr2, 2)
Set rs = New ADODB.Recordset
sql = "select * from 表_调拨明细"
With rs
.Open sql, CurrentProject.Connection, 3, 3
For i = 0 To a
If i = 0 Then
s = arr2(1, i) & arr2(2, i) & arr2(3, i)
ElseIf arr2(0, i) = arr2(0, i - 1) Then
s = s & "," & arr2(1, i) & arr2(2, i) & arr2(3, i)
ElseIf arr2(0, i) <> arr2(0, i - 1) Then
.AddNew
rs("流水号") = arr2(0, i - 1)
rs("调拨明细") = s
.Update
s = arr2(1, i) & arr2(2, i) & arr2(3, i)
End If
Next
.AddNew
rs("流水号") = arr2(0, a)
rs("调拨明细") = s
.Update
MsgBox a + 1 & " " & Timer - e
End With
End Sub

复制代码