VBA 为什么 Delete Shift Up 会删除它下面的所有内容?
VBA Why does Delete Shift Up delete everything below it?
所以我的代码只要在 sheet 上添加一个名称,然后将该名称添加到所有其他 sheet,并且每当从同一个 sheet 中删除一个名称时,它应该从所有其他 sheet 中删除(这些是下面选定的 sheet)。但是出于某种原因 运行 ActiveCell.EntireRow.Delete Shift:=xlUp
也删除了 ActiveCell
以下的所有内容?这是我目前的全部代码。
Private Sub Worksheet_Change(ByVal Target As Range)
Const cCol As String = "A"
Const fRow As Long = 2
Dim crg As Range
Dim ddFound As Range
Dim ws As Worksheet
Dim sh As Worksheet
Dim outpt As String
Dim i As Integer
Set crg = Worksheets("Statistics").Columns(cCol).Resize(Rows.Count - fRow + 1).Offset(fRow - 1)
Dim irg As Range: Set irg = Intersect(crg, Target)
Dim sraddress As String
Dim statdel As Range
Dim dws As Worksheet
Dim ddcrg As Range
Dim statrange As Range
If Not Intersect(Target, Range("A:A")) Is Nothing Then
sraddress = CStr(irg.Value)
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each ws In ActiveWorkbook.Worksheets
Set ddcrg = ws.Columns(cCol)
Set ddFound = ddcrg.Find(sraddress, , xlValues, xlWhole)
If sraddress <> "" Then
irg.Select: ActiveCell = irg.Value2
irg.Copy
ws.Range(irg.Address) = irg.Value2
Application.CutCopyMode = False
ElseIf sraddress = "" Then
Dim Deladdrs As String
irg.EntireRow.Select
On Error Resume Next
Sheets(Array("Statistics", "January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")).Select
Deladdrs = ActiveCell.Address(0, 0)
ActiveCell.EntireRow.Delete Shift:=xlUp
Application.CutCopyMode = False
Else
End If
Next ws
Application.ScreenUpdating = True
Application.EnableEvents = True
Else
End If
End Sub
请测试下一个代码。它假定只应更新数组中的工作表(来自您的代码)。而且,在删除名称的情况下,包含它的行也应该被删除。该代码还涵盖了行删除的情况,否则应该将值放在要更新的工作表的所有行上的新 Target
的 A:A 中:
Private Sub Worksheet_Change(ByVal Target As Range)
Const cCol As String = "A", fRow As Long = 2
Dim crg As Range, ws As Worksheet
Dim irg As Range, irgVal As String
If Target.Rows.Count > 1 then exit sub. Not allowed more rows to be deleted, changed.
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Set crg = Me.Columns(cCol).Resize(rows.Count - fRow + 1).Offset(fRow - 1)
Set irg = Intersect(crg, Target)
irgVal = irg.value
If Target.Columns.Count = 16384 Then irgVal = "" 'for the case of deleting the whole row!
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each ws In Worksheets(Array("January", _
"February", "March", "April", "M)
If irgVal <> "" Then
ws.Range(Target.Address).value = irg.value
Else
ws.rows(irg.row).EntireRow.Delete
End If
Next ws
If CStr(irg.value) = "" Then irg.EntireRow.Delete 'delete also the Target row...
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Sub
以上代码不是为多行删除设计的,改
可以设计一个触发Row deletion的事件(Ribbon级别),但是没有使问题的对象...
所以我的代码只要在 sheet 上添加一个名称,然后将该名称添加到所有其他 sheet,并且每当从同一个 sheet 中删除一个名称时,它应该从所有其他 sheet 中删除(这些是下面选定的 sheet)。但是出于某种原因 运行 ActiveCell.EntireRow.Delete Shift:=xlUp
也删除了 ActiveCell
以下的所有内容?这是我目前的全部代码。
Private Sub Worksheet_Change(ByVal Target As Range)
Const cCol As String = "A"
Const fRow As Long = 2
Dim crg As Range
Dim ddFound As Range
Dim ws As Worksheet
Dim sh As Worksheet
Dim outpt As String
Dim i As Integer
Set crg = Worksheets("Statistics").Columns(cCol).Resize(Rows.Count - fRow + 1).Offset(fRow - 1)
Dim irg As Range: Set irg = Intersect(crg, Target)
Dim sraddress As String
Dim statdel As Range
Dim dws As Worksheet
Dim ddcrg As Range
Dim statrange As Range
If Not Intersect(Target, Range("A:A")) Is Nothing Then
sraddress = CStr(irg.Value)
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each ws In ActiveWorkbook.Worksheets
Set ddcrg = ws.Columns(cCol)
Set ddFound = ddcrg.Find(sraddress, , xlValues, xlWhole)
If sraddress <> "" Then
irg.Select: ActiveCell = irg.Value2
irg.Copy
ws.Range(irg.Address) = irg.Value2
Application.CutCopyMode = False
ElseIf sraddress = "" Then
Dim Deladdrs As String
irg.EntireRow.Select
On Error Resume Next
Sheets(Array("Statistics", "January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")).Select
Deladdrs = ActiveCell.Address(0, 0)
ActiveCell.EntireRow.Delete Shift:=xlUp
Application.CutCopyMode = False
Else
End If
Next ws
Application.ScreenUpdating = True
Application.EnableEvents = True
Else
End If
End Sub
请测试下一个代码。它假定只应更新数组中的工作表(来自您的代码)。而且,在删除名称的情况下,包含它的行也应该被删除。该代码还涵盖了行删除的情况,否则应该将值放在要更新的工作表的所有行上的新 Target
的 A:A 中:
Private Sub Worksheet_Change(ByVal Target As Range)
Const cCol As String = "A", fRow As Long = 2
Dim crg As Range, ws As Worksheet
Dim irg As Range, irgVal As String
If Target.Rows.Count > 1 then exit sub. Not allowed more rows to be deleted, changed.
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Set crg = Me.Columns(cCol).Resize(rows.Count - fRow + 1).Offset(fRow - 1)
Set irg = Intersect(crg, Target)
irgVal = irg.value
If Target.Columns.Count = 16384 Then irgVal = "" 'for the case of deleting the whole row!
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each ws In Worksheets(Array("January", _
"February", "March", "April", "M)
If irgVal <> "" Then
ws.Range(Target.Address).value = irg.value
Else
ws.rows(irg.row).EntireRow.Delete
End If
Next ws
If CStr(irg.value) = "" Then irg.EntireRow.Delete 'delete also the Target row...
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Sub
以上代码不是为多行删除设计的,改
可以设计一个触发Row deletion的事件(Ribbon级别),但是没有使问题的对象...