特殊细胞(xlCellTypeVisible)太慢-提示提高性能?

Im trying to automate a report that have 5 different information sources. Im trying to make a UNION of different tables into a single one using ListObjects, everything is working fine except when I copy the first column of the first ListObject. It takes about 2 minutes to copy the first column, the next columns takes less than 1 second.

我正在尝试自动化一个有5个不同信息源的报告。我试着用ListObject将不同的表合并成一个单独的表，除了复制第一个ListObject的第一列之外，一切都运行得很好。复制第一列大约需要2分钟，而下一列需要不到1秒。

Every time I run the VBA script I delete all the rows of the destination table to start the VBA script with a ListObject with 0 rows.

每次运行VBA脚本时，我都会删除目标表的所有行以启动带有0行的ListObject的VBA脚本。

I'll try to explain how it works:

我会解释它是如何工作的:

Sub ProcesarPresupuesto() 
'This is the first macro that process and copy the information of the first source

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual

'<Here> I add several columns and process the information of this first source, I keep all the rows as values using the Function: AddColumnFormula (at the end of this example). I think this is not causing the problem.

'Then I fill all the Blanks Cells to avoid having empty cells in my final table.
Sheets("Origin").Select
Selection.CurrentRegion.Select
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "Null"
On Error GoTo 0

'When I have the ListObject ready I start copying the columns to the destination

Sheets("Destination").Select
Range("A1").Select
While ActiveCell.Value <> ""
Call CopyColumn("Origin", ActiveCell.Value, "Destination")
ActiveCell.Offset(0, 1).Select
Wend

End Sub

I think this should be very fast. If I delete only the values of the Destination ListObject and keep the rows empty, the first column is copied immediatly so I think the problem is related on how Excel calculate the first rows to be added to the ListObject. Is there a better way to copy a column when the table is empty? Am I doing something really wrong?.

我认为这应该很快。如果我只删除目标ListObject的值并保持行为空，那么第一个列将立即被复制，因此我认为这个问题与Excel如何计算要添加到ListObject中的第一行有关。是否有更好的方法在表为空时复制列?我做错什么了吗?

This is the Function CopyColumn

这是函数CopyColumn

Function CopyColumn(Origin, ColumnName, Destination)
    Range(Origin & "[[" & ColumnName & "]]").Copy Destination:=Range(Destination & "[[" & ColumnName & "]]")
End Function

This is the Function I use to process the columns

这是我用来处理列的函数。

Function AddColumnFormula(DestinationSheet, TableName, ColumnName, Value)

Set NewColumn = Sheets(DestinationSheet).ListObjects(TableName).ListColumns.Add
NewColumn.Name = ColumnName

Set Rango = Range(TableName & "[[" & ColumnName & "]]")
Rango.Value = Value
Rango.Copy
Rango.PasteSpecial (xlPasteValues)

End Function

Thanks in advance for your time and answers

提前感谢您的时间和答案

1 个解决方案

#1

I did some testing with the file you provided. It was slow but I did not time it at first. I saw some opportunities to revise the code which might improve performance, and the timer took 1 minute 16 seconds.

我用你提供的文件做了一些测试。它很慢，但我一开始没有计时。我看到了一些修改代码的机会，可以提高性能，计时器需要1分钟16秒。

I tried a few more things with varying success, using Debug.Print statements to inform me what part of the code was running and how long they were taking. Most executions were about 2 minutes each, the slowest was 3m13s.

我还尝试了一些不同的方法，使用了Debug。打印语句，告诉我代码的哪个部分正在运行，它们需要多长时间。大多数死刑执行时间约为2分钟，最慢的为3m13秒。

In that final 3m13s attempt, I had narrowed my focus to the:

在3m13的最后一次尝试中，我把注意力集中在:

...CurrentRegion.SpecialCells(xlCellTypeBlanks)

…CurrentRegion.SpecialCells(xlCellTypeBlanks)

This is suspect because both CurrentRegion and SpecialCells methods can be expensive. Combining them seemed like a recipe for disaster.

这是可疑的，因为CurrentRegion和specialcell方法都很昂贵。把它们结合起来似乎是一种灾难。

I figured I would try a simple iteration, just to compare performance, and to my surprise, I am able to do a simple For each loop over 42,000 rows and 32 columns of data, and this would execute consistently in about 14 seconds for a total run-time of about 30 seconds.

我想我会尝试一个简单的迭代,比较性能,而让我惊讶的是,我能做一个简单的为每个循环超过42000 32行和列的数据,这将持续约14秒执行总运行时间大约30秒。

Here is the code I use for the loop:

下面是我用于循环的代码:

Dim cl As Range
'Debug.Print "For each ..." & Format(Now(), "hh:mm:ss")
For Each cl In wsP.ListObjects(1).DataBodyRange
    If cl.Value = vbNullString Then cl.Value = "Null"
Next
'Debug.Print "End loop " & Format(Now(), "hh:mm:ss")

Here are my last three results:

以下是我的最后三个结果:

31 seconds:    
    Commencar a 21:09:25
    For each ...21:09:38
    End loop 21:09:52
    CopiarColumnaListOBjectaVacia...21:09:52
    Finito : 5/5/2014 9:09:56 PM

30 seconds:    
    Commencar a 21:10:23
    For each ...21:10:36
    End loop 21:10:49
    CopiarColumnaListOBjectaVacia...21:10:49
    Finito : 5/5/2014 9:10:53 PM

34 seconds:    
    Commencar a 21:18:42
    For each ...21:18:55
    End loop 21:19:09
    CopiarColumna... 21:19:09
    Finito : 5/5/2014 9:19:16 PM

I have saved the revised version of the XLSB on Google Docs, so that you may review in its entirety.

我已经在谷歌文档中保存了XLSB的修改版本，以便您可以完整地审阅。

https://drive.google.com/file/d/0B1v0s8ldwHRYZWhuTmRuaDJoMzQ/edit?usp=sharing

As I said, I did make some changes to this subroutine and also to RenombraColumna, but in hindsight while those may offer some efficiencies, I think the root of the problem was with CurrentRegion.SpecialCells.

正如我所说，我确实对这个子例程和RenombraColumna做了一些修改，但事后看来，虽然这些可能会带来一些效率，但我认为问题的根源在于CurrentRegion.SpecialCells。

I hope you do not mind that I revised the title of this question to be more suitable for the particular problem. As originally stated, the question was not likely to help others with the same symptoms.

我希望你不介意我修改了这个问题的标题，使它更适合这个特定的问题。正如最初所说，这个问题不太可能帮助其他有同样症状的人。

#1