如何使用字典对象查找和组合工作表中重复标题中的数据

Question

我尝试获取存在于第一个图像中的数据(带有标记)，将其放入一个字典对象(我刚刚了解了这个对象)，查找重复的头(在本例中是"P8“条目)，然后获取重复的头并将其与第一次出现的头组合在一起，然后删除与重复头相关联的部分。第二个图像(没有标记)是数据在说完和做完之后应该是什么样子。请注意，“pinlable：[]现在将数据的多个实例组合到一个实例中的副本中。

这是我拼凑出来的代码(我不是程序员，我写的上一个VBA程序是5年前的事，花了我永远的时间，我被这个任务卡住了，因为据我所知，它是我们这个小团队中最重要的部分)我知道它缺少一些关键元素，比如正确地加载密钥，这是因为我不能从我读过的文章和代码中完全理解如何做到这一点。我知道一般的组织步骤，我只是有点迷惑于如何使用字典对象并使其与正确的循环一起工作。因此，我尝试在缺少的部分中进行评论，以确定我认为需要发生的事情。还值得注意的是，此工作表中的数据具有非常特殊的空格、逗号、方括号等格式，因为我的最终输出是馈送到另一个程序的.yml输入文件。所以，如果我能保留格式，那就太好了。

    Sub AltDictSort()

Dim Rng As Range
Dim Dn As Range
Dim n As Long
Dim nRng As Range
Dim tempDN As String
Dim TxtRng As Range

Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))

With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    If .Exists(Dn.Value) Then
         
    'not sure this next line does what I'm intending
    tempDN = .Item(Dn.Value).Offset(2, 0) 'load Dn.Value into temp value should be something like "   pinlabels: [J2-1,J2-2,J2-3]"
    
    Dn.Value = Left(tempDN, Len(tempDN) - 15) 'Strip 15 characters from left to get "J2-1,J2-2,J2-3]"
    tempDN = Dn.Value
    Dn.Value = Right(tempDN, Len(tempDN) - 1) 'Strip 1 characters from right to get "J2-1,J2-2,J2-3"
    tempDN = (Dn.Value + "," + Dn) 'add the two strings together to get something like this "   pinlabels: [J2-1,J2-2,J2-3,J-4,J-5,J-6]"
    
    'now I need to put the combined string back into the spot of the first occurrence of a pinlabels duplicate (in this specific case A8) but need to identify location of first occurrence
    
    'now I need to delete the entire second occurrence ( second P8: and next two rows with mpn and pinlabels) no idea how to do this
    
    Else
    'I don't think anything needs to happen here but I'm not completely sure????
    End If
Next

End With
End Sub

​

​

​

​

@JohnnieL这是输入数据作为文本的样子，尽管它在发布时似乎丢失了格式。

> connectors:   Startup-R-J2:    mpn: 436450310    pinlabels:
> [J2-1,J2-2,J2-3]
> 
>   P8:    mpn: D38999/20JE26PN    pinlabels: [P8-C,P8-D,P8-E]
> 
>   Startup-R-J1:    mpn: 436450310    pinlabels:
> [J1-4,J1-9,J1-3,J1-6,J1-7]
> 
>   P8:    mpn: D38999/20JE26PN    pinlabels: [P8-G,P8-H,P8-I,P8-J,P8-K]
> 
>   Startup-R-J3:    mpn: 170-009-272L000    pinlabels: [J3-3,J3-2,J3-1]
> 
>   P8:    mpn: D38999/20JE26PN    pinlabels: [P8-R,P8-S,P8-T]
> 
>   PTO1-J2:    mpn: 170-009-272L000    pinlabels: [J2-5,J2-6]
> 
>   P8:    mpn: D38999/20JE26PN    pinlabels: [P8-A,P8-B]
> 
>   PTO3-J2:    mpn: 170-009-272L000    pinlabels: [J2-8,J2-7]
> 
>   P8:    mpn: D38999/20JE26PN    pinlabels: [P8-N,P8-P]
> 
>   PTO3-J2:    mpn: 170-009-272L000    pinlabels: [J2-3,J2-4]
> 
>   P8:    mpn: D38999/20JE26PN    pinlabels: [P8-R,P8-S]
> 
> cables:   Startup-R-J2_P8:    wirecount: 3    gauge: 20 AWG    length:
> 100 mm    color_code: IEC
> 
>   Startup-R-J1_P8:    wirecount: 5    gauge: 22 AWG    length: 200 mm 
> color_code: IEC
> 
>   Startup-R-J3_P8:    wirecount: 3    gauge: 24 AWG    length: 300 mm 
> color_code: IEC
> 
>   PTO1-J2_P8:    wirecount: 2    gauge: 26 AWG    length: 400 mm   
> color_code: IEC
> 
>   PTO3-J2_P8:    wirecount: 2    gauge: 28 AWG    length: 500 mm   
> color_code: IEC
> 
>   PTO3-J2_P8:    wirecount: 2    gauge: 30 AWG    length: 600 mm   
> color_code: IEC
> 
> 
> connections:
> -
>   - Startup-R-J2: [J2-1,J2-2,J2-3]
>   - Startup-R-J2_P8: [1-3]
>   - P8: [P8-C,P8-D,P8-E]
> -
>   - Startup-R-J1: [J1-4,J1-9,J1-3,J1-6,J1-7]
>   - Startup-R-J1_P8: [1-5]
>   - P8: [P8-G,P8-H,P8-I,P8-J,P8-K]
> -
>   - Startup-R-J3: [J3-3,J3-2,J3-1]
>   - Startup-R-J3_P8: [1-3]
>   - P8: [P8-R,P8-S,P8-T]
> -
>   - PTO1-J2: [J2-5,J2-6]
>   - PTO1-J2_P8: [1-2]
>   - P8: [P8-A,P8-B]
> -
>   - PTO3-J2: [J2-8,J2-7]
>   - PTO3-J2_P8: [1-2]
>   - P8: [P8-N,P8-P]
> -
>   - PTO3-J2: [J2-3,J2-4]
>   - PTO3-J2_P8: [1-2]
>   - P8: [P8-R,P8-S]

Answer 1

我将从一个类模块开始，它可能看起来像这样--现在让我们将其命名为ConnectorInfo：

Option Explicit
Public ConnectorID As String
Public MPN As String
Public PinLabels As New Collection

我们的想法是对我们正在查看的数据进行建模；输出中表示的每个“对象”都有一个"ConnectorID“值("P8”、"Startup-R-J1“、"PTO3-J2”等)、一个MPN值("436450310“、”170009-272L000“等)和一些需要组合的引脚标签，所以需要有代码将这个PinLabels集合转换为一个字符串，该字符串用逗号分隔它们，并用方括号将列表括起来。

因此，让我们向类模块添加一个公共函数，该函数通过将集合复制到一个数组中，然后使用VBA.Strings.Join函数生成引脚标签列表来完成此操作：

Public Function CombinePinLabels() As String
    ReDim result(1 To PinLabels.Count) As String
    Dim i As Long
    For i = 1 To PinLabels.Count
        result(i) = PinLabels(i)
    Next
    CombinePinLabels = "[" & Join(result, ",") & "]"
End Function

由于输入将以字符串的形式读取PinLabels，我们需要一个过程(因为我们在一个类模块中，我们可以将其称为“方法”)来为我们拼接它们，同时确保没有重复的标签；我们可以通过键控集合项来实现这一点(不需要字典，因为我们实际上并没有访问键)：

Public Sub ParsePinLabels(ByVal inputValue As String)
    'expect inputValue to look like "[123,456,ABC-123,XYZ-000-ABC]"; assert that (i.e. break here before we make a mess):
    Debug.Assert Left$(inputValue, 1) = "["
    Debug.Assert Right$(inputValue, 1) = "]"
    
    'strip the prefix and brackets:
    Dim parsed As String
    parsed = Mid$(inputValue, 2, Len(inputValue - 2))

    Dim values As Variant
    values = Strings.Split(parsed, ",")

    Dim i As Long
    For i = LBound(values) To UBound(values)
        On Error Resume Next 'prevent blowing up when key already exists
        PinLabels.Add values(i), values(i)
        On Error GoTo 0 'important!
    Next
End Sub

注意，输入逻辑和格式在这里基本上是不相关的:需要进行的处理独立于输入格式和输出格式。

那么，让我们构建输出。

...我的最终输出是一个提供给另一个程序的.yml输入文件。

绝对不要考虑操纵Excel对象的想法:您需要的是让代码生成一个.yml文本文件。

处理输入的代码将为生成输出的代码提供一个ConnectorInfo对象集合，因此我们已经知道需要一个过程来实现这一点。在标准模块(例如Module1)中，您希望有一个如下所示的过程：

Public Sub GenerateOutputYML(ByVal connectors As Collection)
    Dim connector As ConnectorInfo
    For Each connector In connectors
       'TODO
    Next
End Sub

但是，我们需要将其输出到特定的文件名-让我们将其作为参数接受，并考虑稍后如何提供它：

Public Sub GenerateOutputYML(ByVal filePath As String, ByVal connectors As Collection)
    Dim handle As Long
    handle = VBA.FreeFile

    On Error GoTo CleanFail 'MUST handle errors when dealing with filesystem I/O
    Open filePath For Output As #handle
    Print #handle, "connectors:"

    'use ForEach..Next loops to iterate object collections
    Dim connector As ConnectorInfo
    For Each connector In connectors
       'each Print # statement writes a line to the text file,
       'Spc() function writes the number of specified spaces to control indentation.
       Print #handle, Spc(2) & connector.ConnectorID & ":"
       Print #handle, Spc(4) & "mpn: " & connector.MPN
       Print #handle, Spc(4) & "pinlabels: " & connector.CombinePinLabels
       Print #handle 'leaves an empty line between connectors
    Next

CleanExit:
    Close #handle
    Exit Sub
CleanFail:
    MsgBox Err.Description
    Resume CleanExit
End Sub

现在剩下的工作就是将输入解析成这样的ConnectorInfo对象的Collection。您可以像在Excel中打开文本文件，然后迭代单元格-或者您可以使用类似的Open语句以编程方式打开内存中的文本文件，它可以驻留在一个接受文件名的函数中，并返回output函数想要使用的集合：

Public Function ParseInput(ByVal intputFilePath As String) As Collection

    Dim handle As Long
    handle = VBA.FreeFile 'gets an available file handle
 
    On Error GoTo CleanFail
    Open inputFilePath For Input As #handle 'never hard-code the handle!

    Dim currentLine As String
    LineInput #handle, currentLine 'read the first line
    Debug.Assert currentLine = "connectors:" 'right?

    Dim contents As Object 'early-bound: As Scripting.Dictionary (requires library reference)
    Set contents = CreateObject("Scripting.Dictionary") 'early-bound: = New Scripting.Dictionary

    Dim currentItem As ConnectorInfo
    Dim currentKey As String

    Do Until EOF(handle)

        LineInput #handle, currentLine
        currentKey = Left$(currentLine, Len(currentLine) - 1) 'strip the colon char

        If contents.Exists(currentKey) Then
            'we have seeen this ID before; fetch it
            Set currentItem = contents(currentKey)
        Else
            'new ID; create a new info object
            Set currentItem = New ConnectorInfo
            contents.Add currentKey, currentItem
        End If

        'assumes MPN is the same for all duplicates of a given ConnectorID

        LineInput#handle, currentLine
        currentItem.MPN = Mid$(currentLine, Len("mpn: "))            

        LineInput#handle, currentLine
        currentItem.ParsePinLabels Mid$(currentLine, Len("pinlabels: ["))

    Loop

    'at this point the items dictionary should contain all the ConnectorInfo objects we want to output.
    'GenerateOutputYML wants a Collection, so we iterate the array returned dictionary's Items function
    Dim result As New Collection

    Dim i As Long 'use a For..Next loop to iterate arrays
    For i = LBound(contents.Items) To UBound(contents.Items)
        result.Add contents.Items(i)
    Next

CleanExit:
    Close #handle
    Set ParseInput = result
    Exit Function
CleanFail:
    MsgBox Err.Description 'for debugging; user doesn't need to see this
    Set result = New Collection 'return an empty collection on error
    Resume CleanFail
End Function

缺少的部分是一个宏，它知道从哪里获取输入文件，在哪里保存输出文件，并调用读取器和写入器过程-现在我们已经抽象出所有血淋淋的细节，剩下一个清晰的高级故事要讲述：

Public Sub ParseYML()
    Const inputFile As String = "C:\Path\Input.txt"
    Const outputFile As String = "C:\Path\Output.yml"

    Dim connectors As Collection
    Set connectors = ParseInput(inputFile)

    If connectors.Count > 0 Then
        GenerateOutputYML outputFile, connectors
        MsgBox "File '" & outputFile & "' was generated successfully for " & connectors.Count & " connectors."
    Else
        MsgBox "No data was read from the specified input file."
    End If

End Sub

这不是唯一可行的方法，但作为一般经验法则，将数据本身(ConnectorInfo)与输入和输出清楚地分开是一个非常好的主意:让数据与正在读取的输入交织在一起，同时生成输出，这可能是可行的……但之后很容易变得很难调整。

通过将解析输入与生成输出分开，您可以更容易地准确隔离需要调整的代码，而不一定会影响代码的其他部分。

Answer 2

使用字典组合字符串

• 调整常量部分中的值。请注意，如果您使用相同的单元格地址，数据将被覆盖。

代码

Option Explicit

Sub AltDictSort()
    
    ' Define constants.
    Const FirstCell As String = "A2"
    Const dstCell As String = "B2"
    Const setsLen As Long = 4
    
    ' Define Source Range.
    Dim rg As Range
    Dim wrCount As Long ' Worksheet Rows Count
    With Range(FirstCell)
        wrCount = .Worksheet.Rows.Count
        Set rg = .Resize(wrCount - .Row + 1) _
            .Find("pinlabels:*", , xlFormulas, xlPart, , xlPrevious)
        If rg Is Nothing Then Exit Sub
        Set rg = .Resize(rg.Row - .Row + 2) ' + 1 because last empty row
    End With
    
    ' Define Sets Count.
    Dim SetsCount As Long: SetsCount = rg.Rows.Count / setsLen
    If rg.Rows.Count Mod setsLen > 0 Then Exit Sub
    
    ' Write values from range to array.
    Dim Data As Variant: Data = rg.Value
    
    Dim rCount As Long ' Result Rows Count
    
    ' Write values from array to dictionary, and back to array.
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        
        Dim arrString() As String: ReDim arrString(1 To 2)
        Dim m As Long: m = 1
        
        Dim n As Long
        Dim iniString As String
        
        For n = 1 To SetsCount
            iniString = Data(m, 1)
            If .Exists(iniString) Then
                arrString = .Item(iniString)
                arrString(2) = combineString(arrString(2), Data(m + 2, 1))
            Else
                arrString(1) = Data(m + 1, 1)
                arrString(2) = Data(m + 2, 1)
            End If
            .Item(iniString) = arrString
            m = m + setsLen
        Next n
        
        rCount = .Count * setsLen
        ReDim Data(1 To rCount, 1 To 1)
        m = 1
        
        Dim Key As Variant
        
        For Each Key In .Keys
            Data(m, 1) = Key
            Data(m + 1, 1) = .Item(Key)(1)
            Data(m + 2, 1) = .Item(Key)(2)
            m = m + setsLen
        Next Key
    
    End With
    
    With rg.Worksheet.Range(dstCell)
        .Resize(wrCount - .Row + 1).ClearContents
        .Resize(rCount).Value = Data
    End With

End Sub

Function combineString( _
    ByVal str1 As String, _
    ByVal str2 As String, _
    Optional ByVal lChar As String = "[", _
    Optional ByVal rChar As String = "]", _
    Optional ByVal Delimiter As String = ",") _
As String
    Dim lPos As Long: lPos = InStr(1, str1, lChar)
    Dim lStr As String: lStr = Left(str1, lPos)
    Dim r1Pos As Long: r1Pos = InStr(1, str1, rChar)
    Dim rStr As String: rStr = Right(str1, Len(str1) - r1Pos + 1)
    Dim m1str As String: m1str = Mid(str1, lPos + 1, r1Pos - lPos - 1)
    Dim r2Pos As String: r2Pos = InStr(1, str2, rChar)
    Dim m2str As String: m2str = Mid(str2, lPos + 1, r2Pos - lPos - 1)
    combineString = lStr & m1str & Delimiter & m2str & rStr
End Function