Question

下午好，

我是VBA的新手，并创建了一个电子表格，我可以在其中输入关于“追逐”的信息。和发送给各种人的电子邮件。我想要一个按钮按下来组织和复制对存档的响应（下一个工作表），这样我就可以知道特定联系人的历史记录。

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

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）和＆＃39;下一步操作＆＃39;列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语句：＆＃39; = IF（ISBLANK（G15），＆＃34;＆＃34;，WORKDAY（G15,2））＆＃39;

Answer 1

我建议有几件事要清理它。

1）为便于参考，您应该为您使用的两张纸张声明一些Worksheet变量。

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，似乎你可以通过使用它来更严格地控制循环（将关闭屏幕更新）

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特别有用，因为您不会对每个新数据行重复排序，您将使用真正的复制/粘贴而不是行插入（速度较慢），并使用{{1}单元格中的公式，以确定要粘贴到您的行，避免空行，因此可以停止花时间删除它们。

为什么这需要这么长时间 - 我在某个地方或某个地方有一个循环吗？

1 个答案: