【发布时间】：2019-07-24 21:02:12
【问题描述】：
我一直致力于使用宏将我们基于 Excel 的销售报告调整为内部 CRM。
这是我使用本网站上的代码设法开始工作的宏：
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0)) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
End If
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 10
xTimeColumn = 11
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Cells(xRow, xTimeColumn) = Now
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Cells(xRg.Row, xTimeColumn) = Now
End If
Next
End If
Dim a As Range
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If CBool(Len(a.Value2)) Then _
a.EntireRow.Copy _
Destination:=Sheet3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
这非常适合我们的基本需求，但每当机会关闭时，我们希望根据机会的结果（赢得、丢失、续订）将其转移到现有数据下方的 3 个单独的工作表中，并从主 CRM 表（又名剪切而不是复制）。这些值是第 10 列中的一些选择，与我上面的脚本中使用的行相同。
周围有无数不同的脚本来完成我想要的某些部分，但不幸的是我无法获得我尝试处理我的文件的任何脚本，因为我们的情况涉及一些不同的工作，所以预期的工作更少“特殊”用例（无过滤器、多个条件、现有表来接收数据等）。
基本上我希望添加到上面的脚本中：
仍将所有行复制到日志表（表 3）
when an entry matching either Won, Lost or Renewed is selected, that entire row should be cut from the CRM sheet (Sheet 1)
该行应粘贴在工作表 2（获胜）、工作表 5（丢失）和工作表 6（更新）中的现有数据下方
任何帮助或建议将不胜感激。
谢谢。
编辑：
我一直在努力让它发挥作用，并且我设法让它发挥作用。
但是当我剪切行时，它也会剪切行的格式，包括数据验证。有什么方法可以剪切数据但保持格式和数据验证设置不变？也许通过使用特殊的粘贴？
这是我使用的代码：
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0)) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
End If
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 10
xTimeColumn = 11
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Worksheets("CRM").Cells(xRow, xTimeColumn) = Now
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Worksheets("CRM").Cells(xRg.Row, xTimeColumn) = Now
End If
Next
End If
Dim a As Range
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If CBool(Len(a.Value2)) Then _
a.EntireRow.Copy _
Destination:=Sheet3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
End If
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Closed Won" Then _
a.EntireRow.Cut _
Destination:=Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Sheets("CRM").Rows(10000).EntireRow.Copy
ActiveCell.EntireRow.Paste
Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Closed Lost" Then _
a.EntireRow.Cut _
Destination:=Sheet5.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Renewal" Then _
a.EntireRow.Cut _
Destination:=Sheet6.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
bm_Safe_Exit:
Application.EnableEvents = True
End Sub【问题讨论】：
-
请注意，您有一些不合格的范围（例如
Cells(xRg.Row, xTimeColumn)、Columns(10)等。我一定要添加应该在它之前的工作表，@987654325 @. -
谢谢。我将它添加到缺少的两行中。