Question

我正在尝试解决Bold中突出显示的代码，从“With ShNew”开始。我取范围，将A：B列复制到LastRow，然后将它们插入最后一行的“Sh3”。 Sh3最后一行是一个Total行，每次运行代码时，它都会插入粘贴的数据，但会覆盖我的总行（最后一行）。我需要插入所有行，并将“Total”行向下移动，而ShiftXLDown似乎也不起作用。

Dim R1 As Range, R2 As Range, Sh1 As Worksheet, Sh2 As Worksheet, ShNew As Worksheet, sh3 As Worksheet, c As Range
    Dim ct As Long, lstrow As Long, lstrow2 As Long
    Dim copyProjects As Range

    Set Sh1 = Sheets("Monthly Actuals")
    Set Sh2 = Sheets("Week 4 - Demand")
    Set sh3 = Sheets("Monthly Pacing Report by Week")
    Set R1 = Sh1.Range("D5:D" & Sh1.Cells(Rows.Count, "D").End(xlUp).Row)
    Set R2 = Sh2.Range("A2:A" & Sh2.Cells(Rows.Count, "A").End(xlUp).Row)


Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("New Sheet").Delete
On Error GoTo 0
ActiveWorkbook.Worksheets.Add.Name = "New Sheet"
Set ShNew = Worksheets("New Sheet")
For Each c In R2
    If IsError(Application.Match(c.Value, R1, 0)) Then
        ct = ct + 1
        Sh2.Rows(c.Row).Copy ShNew.Rows(ct)
    End If
Next c

With sh3
lstrow = sh3.Range("A" & Rows.Count).End(xlUp).Row - 1
.Range("A" & lstrow).Insert Shift:=xlDown
End With

**With ShNew
lstrow2 = .Range("A" & Rows.Count).End(xlUp).Row
Set copyProjects = .Range("A1:B" & lstrow2)
copyProjects.Copy Destination:=sh3.Range("A" & lstrow).Offset(1, 0)
End With**


With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

Answer 1

您可以尝试对代码进行一些重构：

Option Explicit

Sub main()
    Dim R1 As Range, c As Range
    Dim ShNew As Worksheet
    Dim ct As Long, lstrow As Long

    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("New Sheet").Delete
    On Error GoTo 0
    ActiveWorkbook.Worksheets.Add.Name = "New Sheet"
    Set ShNew = Worksheets("New Sheet")

    With Sheets("Monthly Actuals")
        Set R1 = .Range("D5:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    End With

    With Worksheets("Week 4 - Demand")
        For Each c In .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
            If IsError(Application.Match(c.Value, R1, 0)) Then
                ct = ct + 1
                .Rows(c.Row).Copy ShNew.Rows(ct)
            End If
        Next c
    End With

    With Worksheets("Monthly Pacing Report by Week")
        lstrow = .Range("A" & .Rows.Count).End(xlUp).Row
        .Range("A" & lstrow).Resize(ct).EntireRow.Insert xlShiftUp
        ShNew.Range("A1:B" & ct).Copy Destination:=.Range("A" & lstrow)
    End With

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

但是：

所有复制/粘贴工作表都非常耗时

如果你有足够多的数据，那么你最好决定使用数组
关注 Sh3最后一行是总行

如果存在寻址其上方单元格的公式，则在其正上方插入行将不会使该公式自动扩展其操作范围

Answer 2

解决方案目前我找到了：

基本上在代码的末尾，我从工作表中循环x行，并将这些行插入到我的目标工作表中。从那里，目标表将有新的空行，我粘贴我的范围。

Dim R1 As Range, R2 As Range, Sh1 As Worksheet, Sh2 As Worksheet, ShNew As Worksheet, sh3 As Worksheet, c As Range
Dim ct As Long, lstrow As Long, lstrow2 As Long
Dim copyProjects As Range
Dim Rngcount As Range, row As Range
Set Sh1 = Sheets("Monthly Actuals")
Set Sh2 = Sheets("Week 4 - Demand")
Set sh3 = Sheets("Monthly Pacing Report by Week")
Set ShNew = Worksheets("New Sheet")
Set R1 = Sh1.Range("D5:D" & Sh1.Cells(Rows.Count, "D").End(xlUp).row)
Set R2 = Sh2.Range("A2:A" & Sh2.Cells(Rows.Count, "A").End(xlUp).row)
Set Rngcount = ShNew.Range("A:A")
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("New Sheet").Delete
On Error GoTo 0
ActiveWorkbook.Worksheets.Add.Name = "New Sheet"
Set ShNew = Worksheets("New Sheet")
For Each c In R2
    If IsError(Application.Match(c.Value, R1, 0)) Then
        ct = ct + 1
        Sh2.Rows(c.row).Copy ShNew.Rows(ct)
    End If
Next c


With ShNew
For Each row In Rngcount
lstrow = sh3.Range("A" & Rows.Count).End(xlUp).row + 1
If row > 0 Then
sh3.Range("A" & lstrow).EntireRow.Insert
End If
Next row
'
lstrow2 = .Range("A" & Rows.Count).End(xlUp).row
Set copyProjects = .Range("A1:B" & lstrow2)
copyProjects.Copy
sh3.Range("A" & lstrow).PasteSpecial Paste:=xlPasteValues
End With

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

VBA - 复制范围并粘贴到新工作表，将整行向下移动？

2 个答案: