为什么这么长时间 – 我有一个地方或什么东西的循环？

下午好，

我对VBA相当陌生，并创build了一个电子表格，可以input发送给不同人的“追踪”和电子邮件信息。 我想有一个buttonbutton，将组织和复制到档案（下一个工作表）的答复，所以我可以知道一个特定的联系人的历史。

到目前为止，我有这个代码：

Private Sub CommandButton1_Click() Application.ScreenUpdating = False For j = 3 To 50 On Error GoTo Err_Execute Sheets("Current").Rows(j).Copy Sheets("Archive").Rows(j).Insert Shift:=xlDown 'these two copy/paste into the archive Sheets("Archive").Range("A2:H2" & Range("A9999").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'this deletes blank rows Sheets("Archive").Cells.RemoveDuplicates Columns:=Array(1, 2, 6), Header:=xlYes 'this removes duplicates ActiveWorkbook.Worksheets("Current").ListObjects("Table2").Sort.SortFields. _ Clear ActiveWorkbook.Worksheets("Current").ListObjects("Table2").Sort.SortFields.Add _ Key:=Range("Table2[[#All],[Next Chase]]"), SortOn:=xlSortOnValues, Order _ :=xlAscending, DataOption:=xlSortTextAsNumbers With ActiveWorkbook.Worksheets("Current").ListObjects("Table2").Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Next j Application.ScreenUpdating = True Err_Execute: If Err.Number = 0 Then MsgBox "All have been copied!" Else _ MsgBox Err.Description End Sub 

如果有人能够帮助我，整理一下，或者告诉我哪里出错，我会非常感激。 谢谢。

编辑：我想我需要删除空行函数作为还有一块代码时间戳列F入口。当删除不再需要的信息（追逐）我删除行A到F，这使得时间戳（G列），“下一个行动”列H使用Ifblank语句消失。

这是时间戳到F列的代码：

 Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim rCell As Range Dim rChange As Range On Error GoTo ErrHandler Set rChange = Intersect(Target, Range("F:F")) If Not rChange Is Nothing Then Application.EnableEvents = False For Each rCell In rChange If rCell > "" Then With rCell.Offset(0, 1) .Value = Now .NumberFormat = "dd/mm/yy hh:mm" .VerticalAlignment = xlCenter .HorizontalAlignment = xlLeft End With Else rCell.Offset(0, 1).Clear End If Next End If ExitHandler: Set rCell = Nothing Set rChange = Nothing Application.EnableEvents = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub 

和H列中的if语句：'= IF（ISBLANK（G15），“”，WORKDAY（G15,2））'

Answer 1

有几件事我build议清理这个。

1）为了便于参考，您应该为您使用的两张工作表声明一些工作表variables。

 Dim C_S As Worksheet Set C_S = ThisWorkbook.Sheets("Current") Dim A_S as Worksheet Set A_S = ThisWorkbook.Sheets("Archive") 

2）而不是使用For j = 3 To 50 ，似乎你可以通过使用这个更紧密的控制循环（将closures屏幕更新后）

 Dim j as Long j = 3 Do While C_S.Range("G" & j).Value <> "" 'Copy the data C_S.Range("A" & j & ":H" & j).Copy 'Paste it to the next open row in Archive A_S.Range("A" & A_S.Range("I1").Value).PasteSpecial xlPasteAll 'Replace I1 with some cell where you can enter the following formula without worrying about it getting overwritten ' =COUNTA(G:G)+1 ALSO, if there are any blank rows above your data (ex. you leave row 1 blank and have the headers in row 2) you need to increase the "+1" by 1 for each blank 'Increment j j = j + 1 Loop 'Your sort should go here now 

更改2特别有用，因为您不会重复每一行新数据的sorting，您将使用真正的复制/粘贴而不是行插入（这是较慢的），并通过在单元格中使用COUNTA()公式确定要粘贴到你的行，避免有空行，并因此可以停止花时间去除它们。