Question

我正在使用下面的代码将主“All Data”表格中的数据提取到多张图片，即“Set ws”。

Sub ForecastExtract()

    Dim ad As Worksheet
    Dim AFTE As Single
    Dim BlnProjExists As Boolean
    Dim bottomB As Integer
    Dim ColDates As New Collection
    Dim Flex As String
    Dim i As Long
    Dim j As Long
    Dim JRole As String
    Dim LastRow As Long
    Dim m As Long
    Dim OVH As Worksheet
    Dim PDate As Date
    Dim PLOB As String
    Dim Portfolio As String
    Dim PRO As Worksheet
    Dim Project As String
    Dim RLOB As String
    Dim rng As Range
    Dim RngDates As Range
    Dim Task As String
    Dim ws As Worksheet

    Application.ScreenUpdating = False

    Const StartRow As Long = 8

    Set ad = Sheets("All Data")

    bottomB = ad.Range("B" & Rows.Count).End(xlUp).Row

    For Each rng In ad.Range("B8:B" & bottomB)

        Set ws = Sheets(rng.Value)

    For i = 3 To ws.Cells(StartRow - 1, Columns.Count).End(xlToLeft).Column
        m = m + 1
        ColDates.Add m, ws.Cells(StartRow - 1, i).Text
    Next i

    On Error Resume Next
    With Sheets("All Data").Range("I7")
        For i = 1 To .CurrentRegion.Rows.Count - 1
            Portfolio = .Offset(i, -7)
            PLOB = .Offset(i, -6)
            RLOB = .Offset(i, -5)
            JRole = .Offset(i, -2)
            Project = .Offset(i, 0)
            PCode = .Offset(i, 1)
            Task = .Offset(i, 3)
            PDate = .Offset(i, 4)
            FFTE = .Offset(i, 6)
            AFTE = .Offset(i, 8)
            Flex = .Offset(i, 9)

            If Portfolio = ws.Name And InStr(.Offset(i, -2), "Consultancy & Innovation") = 0 And _
            InStr(.Offset(i, 0), "TM - DIR") > 0 And _
            .Offset(i, 4).Value >= Application.Min(ws.Rows(7)) And Flex = "Yes" Then
                Portfolio = .Offset(i, -7)
                Task = .Offset(i, 3)

                With ws.Range("B7")
                    If .CurrentRegion.Rows.Count = 1 Then
                        .Offset(1, 0) = Portfolio
                        j = 1
                    Else
                        BlnProjExists = False
                        For j = 1 To .CurrentRegion.Rows.Count - 1
                            If .Offset(j, 0) = Portfolio Then
                                BlnProjExists = True
                                Exit For
                            End If
                        Next j
                        If BlnProjExists = False Then
                            .Offset(j, 0) = Portfolio
                        End If

                        On Error Resume Next
                    m = ColDates(Format(PDate, "mmm yy"))
                    If Err = 0 Then .Offset(j, m) = .Offset(j, m) + FFTE
                    On Error GoTo 0
                    End If
                End With
            End If
        Next i
        On Error GoTo 0
    End With
    Next rng
    End Sub

问题

当代码移动到第二个工作表以粘贴提取的数据时，我收到以下错误：

This key is already associated with an element of this collection

调试高亮显示以下行：

ColDates.Add m, ws.Cells(StartRow - 1, i).Text

我已经通过互联网和类似帖子的一些解决方案建议添加On error Resume Next...声明，而其他人没有，所以我不确定采取哪种方法。

Answer 1

收藏与字典不同。任何看你的代码，我认为使用字典就足够了。

无论如何，要在代码中进行收集，您需要在关键部分添加一些内容以使其独一无二。

在ColDates.Add m, ws.Cells(StartRow - 1, i).Text中，密钥为ws.Cells(StartRow - 1, i).Text。现在在第二张表中，您的数据必须重复，因此问题。

一种可能的解决方案是在密钥中添加计数器：

ColDates.Add m, ws.Cells(StartRow - 1, i).Text & CStr(m)

VBA密钥已经与收藏相关联

问题

1 个答案: