Question

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

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

B。）遍历现在的~4000行并为每个人创建一个新的工作表。

由于A栏中有许多重复的名称，因此只会创建~10个新工作表

问题是，它运行但运行速度很慢（我收到的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

这会给你一个2D数组。然后你创建一个新的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。

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

Plz评论此版本现在需要执行相同任务的时间。

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

想法使这段代码更有效率

1 个答案: