时间戳

首页 > 解决方案 > 将过滤后的行从工作表复制到另一个工作表的最后一行

excel - 将过滤后的行从工作表复制到另一个工作表的最后一行

问题描述

我一直致力于使用宏将我们基于 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 列中的一些选项，与我上面的脚本中使用的行相同。

周围有无数不同的脚本来完成我想要的某些部分，但不幸的是，我无法获得我试图处理我的文件的任何脚本，因为我们的情况涉及一些不同的“特殊”用途，所以按预期工作要少得多案例（无过滤器、多个条件、现有表来接收数据等）。

基本上我希望添加到上面的脚本中：

任何帮助或建议将不胜感激。

谢谢。

编辑 ：

我一直在努力让它发挥作用，我设法让它发挥作用。

但是当我剪切行时，它也会剪切行的格式，包括数据验证。有什么方法可以剪切数据但保持格式和数据验证设置不变？或许是通过使用特殊的浆糊？

这是我使用的代码：

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

标签： excelvba

解决方案

终于设法让它像我想要的那样工作。

这是其他任何人的代码，这可能会有所帮助。

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

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

如果数据符合指定条件并从 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

推荐阅读