Question

我想知道是否有人可以帮助我。

我将以下代码放在一起，我希望使用它来从'Source'“AllData”表中提取数据并将此信息粘贴到“Destination”“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 列中，但是这些值不正确地重复多次，而我无法复制列中的值< '源'表单上的strong> B 到'目的地'表单上的 C 列。

然而，我可以将“来源”表格中第I列的强制数字加到“目的地”表格上的正确月份。

我上传了文件here，其中包含“来源”“AllData”表和“直接活动”目标表。如果选择“宏”表上的按钮，则可以运行宏。

此外，我还附上了另一张“预期活动”表，展示了我想用宏实现的目标。

我只是想知道是否有人可能会看到这个并提供一些关于如何实现这一目标的指导。

非常感谢和亲切的问候

Answer 1

我发现此代码存在一些问题。

在这一行：
If .Offset(j, 0) = strProject And .Offset(j, 1) = RLOB Then

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

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

和

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

现在，这一行：
With DI.Range("B1")

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

If .CurrentRegion.Rows.Count = 1 Then
到
If .CurrentRegion.Rows.Count = 3 Then

和：
For j = 1 To .CurrentRegion.Rows.Count - 1
到
For j = 1 To .CurrentRegion.Rows.Count - 3

虽然我的偏好是从Range（“B4”）开始并使用.End（xlDown）来选择要搜索的区域。

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

        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

VBA独特的独特列表

1 个答案: