想法使这个代码更有效率

我有一个工作表，其中列出了与关联的数据（列B到G）的人名（列A）。 我有下面的代码，这个约1000行的列表

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

B.）循环到现在〜4000行，并为每个人创build一个新的工作表。

由于A列中有许多重复名称，因此只能创build十个新的工作表

事情是，它运行，但运行速度相当缓慢（我收到Excel没有响应的警告有时）。 有没有什么可以清理这个以提高效率？ 之后，我运行另一个macros将新的工作表保存到一个新的工作簿。 在这里用代码做这个会更快吗？

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 

这给你一个二维数组。 然后你创build一个新的scripiting.dictionary，这将填充一个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的同时，随时创build新的工作表，或稍后循环for i=1 to dict.count ...

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

请注意，这段代码不需要error handling。

PLZ评论这个版本需要多less时间来完成相同的任务。

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