Дублируйте только одну конкретную строку до диапазона несколько раз, основываясь на значении поля ввода, используя VBA

Question

На моем листе 5 столбцов, заполненных данными, и когда я дважды щелкну мышью на любой ячейке, появится поле ввода для ввода «Количество строк» ​​и несколько раз скопировано. До сих пор все работает нормально, но мое требование - только скопировать данные двух столбцов (A & B) и очистить содержимое данных других столбцов только для созданных новых строк.

Мои данные Excel:

Настоящее решение:

Мои требования должны выглядеть следующим образом:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim xCount As Integer
LableNumber:
    xCount = Application.InputBox("Number of Rows", "Copy previous data of Team and Place", , , , , , 1)
    If xCount < 1 Then
        MsgBox "the entered number of rows is error, please enter again", vbInformation
        GoTo LableNumber
    End If
    ActiveCell.EntireRow.Copy
    'copy and move down
    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(xCount, 0)).EntireRow.Insert Shift:=xlDown

    'clear the contents only for new rows added from the column C to column D
    Sheets(ActiveSheet.Name).Range(ActiveCell.Offset(1, 4), ActiveCell.Offset(1, 4)).Select

    Selection.ClearContents

    Application.CutCopyMode = False

End Sub

Answer 1

Попробуй это. Как говорит Брюс, вы можете избежать Select и использовать Target в том виде, в каком оно должно быть.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column > 5 Then Exit Sub 'only applies if A-E double-clicked

Dim xCount As Long
Cancel = True                      'prevent default behaviour of cell edit mode

Do                                 'keep asking until >=1
    xCount = Application.InputBox("Number of Rows", "Copy previous data of Team and Place", , , , , , 1)
    If xCount >= 1 Then Exit Do
    MsgBox "the entered number of rows is error, please enter again", vbInformation
Loop

With Cells(Target.Row, 1)                              'reference point column A of whichever row clicked
    .Resize(, 5).Copy                                  'copy 5 columns across
    .Offset(1).Resize(xCount, 5).Insert Shift:=xlDown  'insert as many rows
    .Offset(1, 2).Resize(xCount, 3).ClearContents      'clear C-E
End With

End Sub