宏在底部插入新行禁用数据验证

Question

Sub InsertRow（）     Dim rActive As Range

Set rActive = ActiveCell

Application.ScreenUpdating = False
With Cells(Rows.Count, "A").End(xlUp)
.EntireRow.Copy
With .Offset(1, 0).EntireRow
.PasteSpecial xlPasteAll
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.DisplayAlerts = True

End Sub

我的问题是，当我的文件与他人共享（共享工作簿）时，我自己和他们可以保存所有内容并添加行，但问题是数据验证不会在新行中复制而下拉会赢得'出现了。

任何人都可以提供帮助吗？

Answer 1

试试这个。您的代码对我有用，所以看起来它可能与共享相关（根据我的评论）。

Sub InsertRow()

Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

End Sub

Answer 2

使用@Captain Grum的代码

Sub InsertRow()

Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

End Sub

它现在复制下面的数据验证，但边框和公式不会复制。

Please see this picture

Answer 3

我真的很抱歉。我真的只是编程的新手。我现在有解决我的问题的方法。我刚才包含了@captain grumpy和我的代码。这是代码：

    Sub InsertRow()
Dim rActive As Range

Set rActive = ActiveCell

Application.ScreenUpdating = False

With Cells(Rows.Count, "A").End(xlUp)
    .Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    .EntireRow.Copy
    With .Offset(1, 0).EntireRow
        .PasteSpecial xlPasteAll
        On Error Resume Next
            .SpecialCells(xlCellTypeConstants).ClearContents
        On Error GoTo 0
    End With

End With



rActive.Select

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub