0

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

我汇总了以下我希望使用的代码，以从“源”“AllData”表中提取数据并将此信息粘贴到“目标”“直接活动”表中。

更加具体：

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

此外，我希望脚本将“源”表上第一列中的所有工作日数字相加，将它们放在“目标”表上的相关月份下。

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列“目的地”表。

但是，我可以将“源”表上的第一列中的工作日数字与“目标”表上的正确月份相加。

我已经在此处上传了带有“源”“AllData”表和“直接活动”“目标表”的文件。如果您选择“宏”表上的按钮，您可以运行宏。

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

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

非常感谢和亲切的问候

4

1 回答 1

0

我看到这段代码有一些问题。

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

您正在 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
于 2013-09-16T17:24:38.273 回答