时间戳

首页 > 解决方案 > 将数据从一张表复制到另一张表的最有效的 vba 方法

excel - 将数据从一张表复制到另一张表的最有效的 vba 方法

问题描述

我只是在尝试从一张 Excel 表到另一张的简单副本，但该程序似乎要花很长时间。

n = WorksheetFunction.CountA(WAEnv.Range("a4:a" & WAEnv.Rows.Count))
ro = 3

For i = 4 To n + 4
    If Len(Trim(WAEnv.Cells(i, 1).Value)) > 0 Then
       ro = ro + 1
       WAPatch.Cells(ro, 1).RowHeight = WAEnv.Cells(i, 1).RowHeight
       WAPatch.Cells(ro, 1).Value = Trim(WAEnv.Cells(i, 1).Value)
       WAPatch.Cells(ro, 2).Value = Trim(WAEnv.Cells(i, 2).Value)
       WAPatch.Cells(ro, 3).Value = Trim(WAEnv.Cells(i, 3).Value)
       WAPatch.Cells(ro, 4).Value = Trim(WAEnv.Cells(i, 4).Value)
       WAPatch.Cells(ro, 5).Value = Trim(WAEnv.Cells(i, 5).Value)
    End If
Next i

有没有更快或更有效的方法来做到这一点？

标签： excelvba

解决方案

如果RowHeight可以牺牲设置的目标，则可以尝试以下代码（显然在修改工作表后，范围详细信息符合您的要求）

Sub test()
Dim WAEnv As Worksheet, WAPatch As Worksheet, Rng As Range
Dim SrcArr As Variant, DstArr() As Variant
Dim Rw As Long, cl As Range
Dim Xrow As Long, Xcol As Long, Lastrow As Long
Dim Chunk60K As Long
Dim tm As Double
tm = Timer

Set WAEnv = ThisWorkbook.Sheets("Sheet3")
Set WAPatch = ThisWorkbook.Sheets("Sheet4")

Set Rng = WAEnv.Range("A4:E" & WAEnv.Cells(Rows.Count, 1).End(xlUp).Row)
SrcArr = Rng.Value
Xrow = 1
Chunk60K = 0

    For Rw = 1 To UBound(SrcArr, 1)
        If SrcArr(Rw, 1) > 0 Then
        ReDim Preserve DstArr(1 To 5, 1 To Xrow)
            For Xcol = 1 To 5
            DstArr(Xcol, Xrow) = SrcArr(Rw, Xcol)
            Next Xcol

            If Xrow = 60000 Then  ' To Overcome 65K limit of Application.Transpose
            WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
            Chunk60K = Chunk60K + 1
            Xrow = 1
            ReDim DstArr(1 To 5, 1 To 1)
            Debug.Print "Chunk: " & Chunk60K & " Seconds Taken: " & Timer - tm
            Else
            Xrow = Xrow + 1
            End If

        End If
    Next Rw


WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
Debug.Print "Completed at Chunk: " & Chunk60K & " Total Seconds Taken: " & Timer - tm

End Sub

代码大约需要 7-8 秒来处理大约 300 K 行（大约 1/2 被过滤掉）

由于我个人不喜欢关闭计算、事件处理和屏幕更新（在正常情况下），我没有添加标准行。但是，您可以使用这些标准技术，具体取决于工作文件条件。

编辑：添加包括行高设置的代码（150 K 后不稳定）

Sub test4()
Dim WAEnv As Worksheet, WAPatch As Worksheet, Rng As Range
Dim SrcArr As Variant, DstArr() As Variant
Dim Rw As Long, cl As Range
Dim Xrow As Long, Xcol As Long, Lastrow As Long
Dim Chunk60K As Long
Dim tm As Double
tm = Timer


Set WAEnv = ThisWorkbook.Sheets("Sheet3")
Set WAPatch = ThisWorkbook.Sheets("Sheet4")
'n = WorksheetFunction.CountA(WAEnv.Range("a4:a" & WAEnv.Rows.Count))

Lastrow = WAEnv.Cells(Rows.Count, 1).End(xlUp).Row
Debug.Print Lastrow
Xrow = 1
Chunk60K = 0

        For Rw = 4 To Lastrow
        Set Rng = WAEnv.Range("A" & Rw & ":E" & Rw)
        If Rng(1, 1).Value > 0 Then
        ReDim Preserve DstArr(1 To 5, 1 To Xrow)
        Xcol = 1
            For Each cl In Rng.Columns.Cells
            DstArr(Xcol, Xrow) = cl.Value
            Xcol = Xcol + 1
            Next cl
        WAPatch.Cells(Xrow, 1).RowHeight = Rng(1, 1).RowHeight

            If Xrow = 60000 Then  ' To Overcome 65K limit of Application.Transpose
            WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
            Chunk60K = Chunk60K + 1
            Xrow = 1
            ReDim DstArr(1 To 5, 1 To 1)
            Debug.Print "Chunk: " & Chunk60K & " Seconds Taken: " & Timer - tm
            Else
            Xrow = Xrow + 1
            End If
      End If
      Next Rw


WAPatch.Range("A" & Chunk60K * 60000 + 3).Resize(UBound(DstArr, 2), UBound(DstArr, 1)).Formula = Application.Transpose(DstArr)
Debug.Print "Completed at Chunk: " & Chunk60K & " Total Seconds Taken: " & Timer - tm

End Sub

推荐阅读