Question

我一直在努力使用宏将基于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页）
当选择匹配“成功”，“丢失”或“更新”的条目时，应从CRM表（第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

Answer 1

最终设法按照我想要的方式工作。

这是可能对其他人有用的代码。

第一部分插入修改单元格的日期。

第二部分将数据复制到日志页面

如果第三部分符合指定条件，则将数据复制到右侧选项卡，并从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
        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.Copy _
        Destination:=Sheet2.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 = "Closed Won" Then _
                a.EntireRow.Delete
    Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
    If Target.Value = "Closed Lost" Then _
        a.EntireRow.Copy _
        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 = "Closed Lost" Then _
                a.EntireRow.Delete
    Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
    If Target.Value = "Renewal" Then _
        a.EntireRow.Copy _
        Destination:=Sheet6.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.Delete
    Next a

bm_Safe_Exit:
    Application.EnableEvents = True

End Sub

将筛选出的行从工作表复制到另一个工作表的最后一行

1 个答案: