使此代码更高效的想法

Question

我有一个工作表，其中列出了人名（A 列）和相关数据（B 到 G 列）。我有下面的代码，它包含一个~1000行的列表

A.) 首先复制并粘贴每一行三次（为每个条目创建四个相同的行）然后

B.) 循环现在约 4000 行，并为每个人创建一个新工作表。

由于 A 列中有许多重复名称，这只会创建 ~ 十个新工作表

问题是，它运行但运行速度很慢（有时我会收到 Excel 没有响应的警告）。有什么可以清理它以提高效率吗？在此之后，我运行另一个宏以将新工作表保存到新工作簿中。在这里使用代码执行此操作会更快吗？

Sub Split_Data()

'This will split the data in column A out by unique values

    Const NameCol = "A"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Dim SrcRow As Long
    Dim LastRow As Long
    Dim TrgRow As Long
    Dim person As String
    Dim lRow As Long
    Dim RepeatFactor As Variant

'Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

'Add four rows
    lRow = 2
    Do While (Cells(lRow, "B") <> "")
        RepeatFactor = 4

        Range(Cells(lRow, "A"), Cells(lRow, "G")).Copy
        Range(Cells(lRow + 1, "A"), Cells(lRow + RepeatFactor - 1, "G")).Select

        Selection.Insert Shift:=xlDown
        lRow = lRow + RepeatFactor - 1    
        lRow = lRow + 1
    Loop

    Set SrcSheet = ActiveSheet
    LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
    For SrcRow = FirstRow To LastRow
        person = SrcSheet.Cells(SrcRow, NameCol).Value
        Set TrgSheet = Nothing
        On Error Resume Next
        Set TrgSheet = Worksheets(person)
        On Error GoTo 0
        If TrgSheet Is Nothing Then
            Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            TrgSheet.Name = person
            SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
        End If
        TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
        SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
    Next SrcRow

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Answer 1

首先，您一次性读取名称列并将其放入 VBA 数组中：

Dim DATA()
with SrcSheet
    DATA= .range(.cells(FirstRow, NameCol), .cells(lastRow, namecol)).value2
end with

这为您提供了一个二维数组。 然后创建一个新的 scripiting.dictionary ，用 DATA 填充 for 循环，每次名称不存在时，将其添加到字典中。

Dim Dict as new scripting.dictionary 'needs a reference in VBE to : Microsoft Scripting Runtime
dim i& 'long
dim h$ 'string 
for i=1 to lastrow-firstrow+1
    h=DATA(i,1)
    if not dict.exists(h) then
        dict(h)=i 'creaates an entry with key=h, item=whatever , here i
    end if
next i

您可以在向 Dict 添加条目时即时创建新工作表，或者稍后循环 for i=1 to dict.count ...

最后，你重置所有：erase DATA : set Dict=nothing。

请注意，此代码不需要错误处理。

请评论一下这个版本现在需要多少时间来完成同样的任务。

编辑：您的 do while 看起来很慢 (copy select, insert)。如果可能的话B.value2=A.value2 从范围的角度来看。