Excel 中vab代码执行速度非常慢，不知道哪里需要改进呢

centryjie 2013-07-11 11:02:27

代码实现功能，根据第一张sheet中客户编号数据从另一个sheet中匹配到客户详细信息后，把客户信息提取复制到第一个sheet中客户编号后，这个过程速度非常慢，不知道哪里有问题

Private Sub cbAddCIS_Click()

Dim pvtTable As PivotTable
Dim oListObj As ListObject, oLO As ListObject
Dim f_rng As Range
Dim oNewRow As ListRow
Dim f_rowno As Long, f_colno As Long, t_colno As Long, r_pos As Long,
c_pos As Long
Dim lookup_value As String, lookup_col_name As String, result_col_name As
String
Dim found As Boolean

On Error Resume Next

Set pvtTable = ActiveSheet.PivotTables("客户资产汇总表")
Set f_rng = pvtTable.RowRange
Set oListObj = Worksheets("客户资产汇总").ListObjects("附加客户信息")
Set oLO = Worksheets("客户信息").ListObjects("客户信息表")

Call cbDelCIS_Click '先清除附加的客户信息

For f_rowno = 2 To f_rng.Rows.Count - 1 '处理每个行数据（去除标题行和汇总
行）
'插入一空行
Set oNewRow = oListObj.ListRows.Add

'用非空的查找要素（客户号、身份证或姓名）去查找客户信息
found = False
For f_colno = 1 To f_rng.Columns.Count

lookup_value = f_rng.Cells(f_rowno, f_colno)
lookup_col_name = f_rng.Cells(1, f_colno)

If (lookup_value <> "" And lookup_value <> "(空白)") Then

r_pos = 0
r_pos = WorksheetFunction.Match(lookup_value, oLO.ListColumns
(lookup_col_name).DataBodyRange, 0)
If r_pos > 0 Then
found = True
Exit For
End If

End If

Next

If found Then '找到的话，逐一添加客户信息各要素
For t_colno = 1 To oListObj.ListColumns.Count
result_col_name = oListObj.ListColumns(t_colno).Name

c_pos = 0
c_pos = WorksheetFunction.Match(result_col_name,
oLO.HeaderRowRange, 0)
If c_pos > 0 Then
oNewRow.Range.Cells(1, t_colno) = oLO.DataBodyRange.Cells(r_pos,
c_pos)
End If

Next
End If

Next

End Sub

Private Sub cbDelCIS_Click()
Dim rng As Range

Set rng = Worksheets("客户资产汇总").ListObjects("附加客户信息
").DataBodyRange

If rng Is Nothing Then
Exit Sub
End If

rng.Delete

End Sub

Private Sub cbrefresh_Click()

Dim pvtTable As PivotTable

Set pvtTable = ActiveSheet.PivotTables("客户资产汇总表")

pvtTable.RefreshTable

If Worksheets("客户资产汇总").ListObjects("附加客户信息").DataBodyRange
Is Nothing Then
Exit Sub
End If

'Call cbAddCIS_Click

End Sub

...全文