复制范围并粘贴到下一个可用行/但更改 b 列第一行的值？

Question

我正在使用以下宏来复制范围并将其粘贴到下一个可用行。

Dim NextRow As Range
Sub Save8()
Dim sht As Worksheet, currentRow As Range
Application.ScreenUpdating = False
Set sht = Sheets("Time Allocation")
Set currentRow = sht.Range(sht.UsedRange.Address)
Set NextRow = currentRow.Offset(currentRow.Rows.Count, 0)

Sheets("Time Allocation").Range("B506:L515").Copy
'NextRow.PasteSpecial Paste:=1, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NextRow.PasteSpecial xlPasteAll
Application.CutCopyMode = False
Set NextRow = Nothing
Set currentRow = Nothing
Set sht = Nothing
Application.ScreenUpdating = True
End Sub

代码工作正常，但是说我要复制的范围如下所示：

Example 1       Test
Test            Test
Test            Test
Test            Test

然后，我的代码会将复制的范围粘贴到原始范围下方，如下所示：

Example 1           Test
    Test            Test
    Test            Test
    Test            Test
Example 1           Test
    Test            Test
    Test            Test
    Test            Test

但现在我想增加 b 列“示例 1”中左上角单元格中的值

所以每次复制和粘贴范围时，我都会得到类似的结果：

Example 1           Test
    Test            Test
    Test            Test
    Test            Test
Example 2           Test
    Test            Test
    Test            Test
    Test            Test
Example 3           Test
    Test            Test
    Test            Test
    Test            Test

请有人告诉我如何做到这一点？提前致谢

Answer 1

粘贴或特殊粘贴的目标位置只能是左上角的单元格。如果您使用它来定位目标，那么 B 列中的相同位置可用于插入公式。

Sub Save8()
    Dim nr As Long

    Application.ScreenUpdating = False

    With Sheets("Time Allocation")
        nr = .Cells(Rows.Count, 2).End(xlUp).Row + 1
        .Range("B506:L515").Copy _
          Destination:=.Cells(nr, 2)
        .Cells(nr, 2).Formula = "=TEXT(COUNTIF(B$1:INDEX(B:B, ROW()-1), ""example*"")+1, ""\Ex\a\mpl\e 0"")"
        'uncomment the next line if you want to remove the formula
        '.Cells(nr, 2) = .Cells(nr, 2).Value2
    End With

    Application.ScreenUpdating = True
End Sub

通过取消注释上面的行，可以将公式恢复为其返回值。