VBA唯一不同列表

我想知道是否有人能帮助我

我将下面的代码放在一起，希望使用它们从“源”的“AllData”工作表中提取数据，并将这些信息粘贴到“目标”的“Direct Activities”工作表中

更具体地说：

• 我希望脚本在“目的地”表的E列中查找文本值“DIR”
• 当它发现这一点时，复制列D和B中的值，并为这两个列创建唯一的不同列表，然后
• 将D列中的值粘贴到B列，将B列中的值粘贴到“目的地”页上的C列

此外，我希望脚本将“来源”表中I列中的所有法定人数相加，并将其放在“目的地”表中相关月份的下方

Sub Extract()

    Dim i As Long, j As Long, m As Long, strProject As String, RLOB As String, RDate As Date, RVal As Single
    Dim BlnProjExists As Boolean, ws As Worksheet, DI As Worksheet, LastRow As Long
    Const StartRow As Long = 5

    Application.ScreenUpdating = False

    Set DI = Sheets("Direct Activities")


    With Sheets("AllData").Range("E3")
        For i = 1 To .CurrentRegion.Rows.Count - 1
            strProject = .Offset(i, 0)
            RDate = .Offset(i, 3)
            RVal = .Offset(i, 4)
            RLOB = .Offset(i, -3)

         If InStr(.Offset(i, 0), "DIR") > 0 And RVal > 0 Then
            strProject = .Offset(i, -1)
            RLOB = .Offset(i, -3)
            With DI.Range("B1")
                If .CurrentRegion.Rows.Count = 1 Then
                    .Offset(1, 0) = strProject
                    j = 1
                Else
                    BlnProjExists = False
                    For j = 1 To .CurrentRegion.Rows.Count - 1
                         If .Offset(j, 0) = strProject And .Offset(j, 1) = RLOB Then
                            BlnProjExists = True
                            Exit For
                        End If
                    Next j
                        If BlnProjExists = False Then
                          .Offset(j, 0) = strProject
                        End If
                End If
                Select Case Format(RDate, "mmm yy")
                    Case "Apr 13"
                        m = 1
                    Case "May 13"
                        m = 2
                    Case "Jun 13"
                        m = 3
                    Case "Jul 13"
                        m = 4
                    Case "Aug 13"
                        m = 5
                    Case "Sep 13"
                        m = 6
                    Case "Oct 13"
                        m = 7
                    Case "Nov 13"
                        m = 8
                    Case "Dec 13"
                        m = 9
                    Case "Jan 14"
                        m = 10
                    Case "Feb 14"
                        m = 11
                    Case "Mar 14"
                        m = 12
                End Select
                        m = m + 1
                 .Offset(j, m) = .Offset(j, m) + RVal
            End With


         End If
        Next i
    End With

     Application.ScreenUpdating = True
    End Sub

我可以将B列中的值粘贴到“目的地”工作表上，但是这些值被错误地重复了多次，并且我无法将“源”工作表上的B列中的值复制到“目的地”工作表上的C列中

但是，我可以将“来源”表第I列中的人员日数字与“目的地”表中的正确月份相加

Sub Extract()

    Dim i As Long, j As Long, m As Long, strProject As String, RLOB As String, RDate As Date, RVal As Single
    Dim BlnProjExists As Boolean, ws As Worksheet, DI As Worksheet, LastRow As Long
    Const StartRow As Long = 5

    Application.ScreenUpdating = False

    Set DI = Sheets("Direct Activities")


    With Sheets("AllData").Range("E3")
        For i = 1 To .CurrentRegion.Rows.Count - 1
            strProject = .Offset(i, 0)
            RDate = .Offset(i, 3)
            RVal = .Offset(i, 4)
            RLOB = .Offset(i, -3)

         If InStr(.Offset(i, 0), "DIR") > 0 And RVal > 0 Then
            strProject = .Offset(i, -1)
            RLOB = .Offset(i, -3)
            With DI.Range("B1")
                If .CurrentRegion.Rows.Count = 1 Then
                    .Offset(1, 0) = strProject
                    j = 1
                Else
                    BlnProjExists = False
                    For j = 1 To .CurrentRegion.Rows.Count - 1
                         If .Offset(j, 0) = strProject And .Offset(j, 1) = RLOB Then
                            BlnProjExists = True
                            Exit For
                        End If
                    Next j
                        If BlnProjExists = False Then
                          .Offset(j, 0) = strProject
                        End If
                End If
                Select Case Format(RDate, "mmm yy")
                    Case "Apr 13"
                        m = 1
                    Case "May 13"
                        m = 2
                    Case "Jun 13"
                        m = 3
                    Case "Jul 13"
                        m = 4
                    Case "Aug 13"
                        m = 5
                    Case "Sep 13"
                        m = 6
                    Case "Oct 13"
                        m = 7
                    Case "Nov 13"
                        m = 8
                    Case "Dec 13"
                        m = 9
                    Case "Jan 14"
                        m = 10
                    Case "Feb 14"
                        m = 11
                    Case "Mar 14"
                        m = 12
                End Select
                        m = m + 1
                 .Offset(j, m) = .Offset(j, m) + RVal
            End With


         End If
        Next i
    End With

     Application.ScreenUpdating = True
    End Sub

我已经上传了带有“源”“所有数据”表和“直接活动”“目标”表的文件。如果选择“宏”表上的按钮，则可以运行宏

此外，我还包括了另一张“预期活动”表，显示了我希望通过宏实现的目标

我只是想知道是否有人可以看看这一点，并提供一些指导，我可以如何实现这一点

---

非常感谢和亲切的问候

我发现这段代码有一些问题

在这行：

如果.Offset（j，0）=strProject和.Offset（j，1）=RLOB那么

您正在查找B列和C列上的现有匹配项，但只填充B列。您需要将其设置为：

.Offset(1, 0) = strProject
.Offset(1, 1) = RLOB 'added line

以及：

现在，这一行：

带有DI.范围（“B1”）

将开始填充工作表顶部的行，我假设您不希望这样。将其更改为“B4”。由于这会更改空表中的行数，因此还需要更改：

如果.CurrentRegion.Rows.Count=1，则


到

如果.CurrentRegion.Rows.Count=3，则


和：

j=1到.CurrentRegion.Rows.Count-1的


到

j=1到.CurrentRegion.Rows.Count-3的


虽然我的首选是从范围（“B4”）开始，然后使用.End（xlDown）选择要搜索的区域

当我运行脚本并进行以下更改时，它产生的结果与您的“预期”工作表相同：

首先，为什么要在行中循环查找文本？为什么不使用
.Find
和
.FindNext
。看到了吗？你能发布一些样本源数据吗？嗨@SiddharthRout，非常感谢你花时间回复我的帖子。我对VBA还比较陌生，我得到了一些帮助来编写我发布的脚本，我是在这个脚本上构建的，所以我不知道还有其他方法来实现这一点。非常感谢和亲切的问候您尝试做的事情相对来说非常简单，如果您遇到困难，我们将很乐意帮助您。。现在看一下文件：）嗨@Joe，谢谢你花时间回复我的帖子。示例“源”数据显示在“AllData”选项卡或我发布链接的文件上。如有任何问题，请随时联系。非常感谢和亲切的regardsHi@Joe，非常感谢您抽出时间来做这件事。这个解决方案非常有效！也谢谢你的解释，这非常有帮助。祝你一切都好，乔，很抱歉打扰你，希望你能把这个捡起来。您昨天很友好地帮助我解决了上述问题，代码运行得很好。不幸的是，我不得不更改我的目标工作表，因此标题行现在是第6行，而不是第4行，因此数据从第7行开始，而不是第5行。我尝试过用DI.Range（“B6”）对这一行进行更改，但似乎无法使其正常工作。能否请您就我需要如何进行更改提供一些指导。麻烦你在代码中再添加一些注释。非常感谢,regards@IRHM带有DI..
的
行设置了数据的开始，因此如果数据所在的位置是
范围（“B7”）
。另外，下面的行应该改为
。Count=6
，这是一个空区域中的行数。您好@Joe，非常感谢您带着这个返回给我，非常感谢。我已经尝试了你提出的建议，不幸的是，这不再列出正确的条目数量。我真的很抱歉再次给你添麻烦。如果我发布另一个文件会有帮助吗？非常感谢和亲切的regardsHi@Joe，只是一个很快的便条，说我已经解决了这个问题。我用DI.Range（“B1”）
将
更改为B6，并将
计数保留为3。再次衷心感谢您的时间、麻烦和耐心。问候
        With DI.Range("B4") ' changed from b1
            If .CurrentRegion.Rows.Count = 3 Then ' changed from 3
                .Offset(1, 0) = strProject
                .Offset(1, 1) = RLOB ' added
                j = 1
            Else
                BlnProjExists = False
                For j = 1 To .CurrentRegion.Rows.Count - 3
                     If .Offset(j, 0) = strProject And .Offset(j, 1) = RLOB Then
                        BlnProjExists = True
                        Exit For
                    End If
                Next j
                    If BlnProjExists = False Then
                      .Offset(j, 0) = strProject
                      .Offset(j, 1) = RLOB ' added
                    End If
            End If