Macro to count hyphenated range

ukbulldog001 · May 28, 2024

Dear MrExcelites,

Need your help in modifying below macro to count hyphenated range as below.

VBA Code:

Sub ConcatenateRefDesignator()
    Dim a, w
    Dim i&
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
            Else
                w = .item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                .item(a(i, 1)) = w
            End If
        Next
        Range("E3").Resize(.count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

Below is the result what I'm getting as of now with above code.



CPN	REF DES	CPN	REF DES	Count
0654-9401-05	C001	0654-9401-05	C001,C002,C074-C080,C011,C012	5
0654-9401-05	C002	0656-9254-77	C003,C008,C010,C013,C014,C015,C017	7
0656-9254-77	C003	0654-9431-01	C005	1
0654-9401-05	C074-C080	0657-9051-06	C007	1
0654-9431-01	C005	0654-8411-04	C009	1
0657-9051-06	C007	0659-9111-54	C018,C019,C020	3
0656-9254-77	C008
0654-8411-04	C009
0656-9254-77	C010
0654-9401-05	C011
0654-9401-05	C012
0656-9254-77	C013
0656-9254-77	C014
0656-9254-77	C015
0656-9254-77	C017
0659-9111-54	C018
0659-9111-54	C019
0659-9111-54	C020

Below is the required result where the count should be 11 instead of 5



CPN	REF DES	CPN	REF DES	Count
0654-9401-05	C001	0654-9401-05	C001,C002,C074-C080,C011,C012	11
0654-9401-05	C002	0656-9254-77	C003,C008,C010,C013,C014,C015,C017	7
0656-9254-77	C003	0654-9431-01	C005	1
0654-9401-05	C074-C080	0657-9051-06	C007	1
0654-9431-01	C005	0654-8411-04	C009	1
0657-9051-06	C007	0659-9111-54	C018,C019,C020	3
0656-9254-77	C008
0654-8411-04	C009
0656-9254-77	C010
0654-9401-05	C011
0654-9401-05	C012
0656-9254-77	C013
0656-9254-77	C014
0656-9254-77	C015
0656-9254-77	C017
0659-9111-54	C018
0659-9111-54	C019
0659-9111-54	C020

Can we use the numeric part of C074-C080 to derive the result as 11 like 074-080=7 count.

Snakehips · May 28, 2024

@ukbulldog001 I am unable to run the below but hope it will do what you wish.
Test it and see.

VBA Code:

Sub ConcatenateRefDesignator()

    Dim a, w
    Dim i&
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                If a(i, 2) Like "*-*" Then w(2) = w(2) + Mid(a(i, 2), 7, 3) - Mid(a(i, 2), 2, 3)
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E3").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

ukbulldog001 · May 29, 2024

Snakehips said:

@ukbulldog001 I am unable to run the below but hope it will do what you wish.
Test it and see.

VBA Code:

Sub ConcatenateRefDesignator()

    Dim a, w
    Dim i&
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                If a(i, 2) Like "*-*" Then w(2) = w(2) + Mid(a(i, 2), 7, 3) - Mid(a(i, 2), 2, 3)
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E3").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

@Snakehips

Although the code works for first set of data, it does not do the same for subsequent lines.
example if 10th row data is changed to C055-C060 then G7 should actually be 6 instead its shows as 1.
Here is the output for your code.



CPN	REF DES	CPN	REF DES	Count
0654-9401-05	C001	0654-9401-05	C001,C002,C074-C080,C011,C012	11
0654-9401-05	C002	0656-9254-77	C003,C008,C010,C013,C014,C015,C017	7
0656-9254-77	C003	0654-9431-01	C005	1
0654-9401-05	C074-C080	0657-9051-06	C007	1
0654-9431-01	C005	0654-8411-04	C055-C060	1
0657-9051-06	C007	0659-9111-54	C018,C019,C020	3
0656-9254-77	C008
0654-8411-04	C055-C060
0656-9254-77	C010
0654-9401-05	C011
0654-9401-05	C012
0656-9254-77	C013
0656-9254-77	C014
0656-9254-77	C015
0656-9254-77	C017
0659-9111-54	C018
0659-9111-54	C019
0659-9111-54	C020

Snakehips · May 29, 2024

@ukbulldog001 Sorry but I still cannot test.
Try this.

VBA Code:

Sub ConcatenateRefDesignator()

    Dim a, w
    Dim i&
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
               If a(i, 2) Like "*-*" Then .Item(a(i, 1)) = Mid(a(i, 2), 7, 3) - Mid(a(i, 2), 2, 3)
               
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                If a(i, 2) Like "*-*" Then w(2) = w(2) + Mid(a(i, 2), 7, 3) - Mid(a(i, 2), 2, 3)
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E3").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

ukbulldog001 · May 29, 2024

Snakehips said:

@ukbulldog001 Sorry but I still cannot test.
Try this.

VBA Code:

Sub ConcatenateRefDesignator()

    Dim a, w
    Dim i&
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
               If a(i, 2) Like "*-*" Then .Item(a(i, 1)) = Mid(a(i, 2), 7, 3) - Mid(a(i, 2), 2, 3)
              
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                If a(i, 2) Like "*-*" Then w(2) = w(2) + Mid(a(i, 2), 7, 3) - Mid(a(i, 2), 2, 3)
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E3").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

Still didn't work as intended.
Anyway had to change the approach and implement a helper column and then later delete the same to derive the intended result.
Posting the working code. It might come in handy for someone.

VBA Code:

Sub ConcatenateRefDesignator()
    Dim ws As Worksheet
    Dim dict As Object
    Dim rng As Range
    Dim cell As Range
    Dim lastRow As Long
    Dim uniqueList As Collection
    Dim i As Long
    Dim key As Variant
    Dim expandedData As String
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set dict = CreateObject("Scripting.Dictionary")
    Set uniqueList = New Collection
    
    lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
    
    For Each cell In ws.Range("A3:A" & lastRow)
        If Not dict.exists(cell.Value) Then
            dict.Add cell.Value, cell.Value
            uniqueList.Add cell.Value
        End If
    Next cell

    For i = 1 To uniqueList.count
        ws.Cells(i + 2, 5).Value = uniqueList(i)
    Next i

    For Each key In dict.Keys
        dict(key) = ""
        For Each cell In ws.Range("A3:A" & lastRow)
            If cell.Value = key Then
                If dict(key) = "" Then
                    dict(key) = ws.Cells(cell.Row, 2).Value
                Else
                    dict(key) = dict(key) & ", " & ws.Cells(cell.Row, 2).Value
                End If
            End If
        Next cell
    Next key

    For i = 1 To uniqueList.count
        ws.Cells(i + 2, 6).Value = dict(uniqueList(i))
    Next i

    lastRow = ws.Cells(ws.Rows.count, "F").End(xlUp).Row

    ws.Range("G3:H" & lastRow).Clear

    For i = 3 To lastRow
        expandedData = ExpandedSeries(ws.Cells(i, "F").Value)
        ws.Cells(i, "H").Value = expandedData
    Next i

    For i = 3 To lastRow
        ws.Cells(i, "G").Value = Len(ws.Cells(i, "H").Value) - Len(Replace(ws.Cells(i, "H").Value, ",", "")) + 1
    Next i

    ws.Columns("H").Delete

End Sub

Function ExpandedSeries(ByVal S As String) As String
    Dim X As Long, Z As Long
    Dim Letter As String, NumberLeft As String, NumberRight As String, Parts() As String
    S = Replace(Replace(Application.Trim(Replace(S, ",", " ")), " -", "-"), "- ", "-")
    Parts = Split(S)
    For X = 0 To UBound(Parts)
        If Parts(X) Like "*-*" Then
            For Z = 1 To InStr(Parts(X), "-") - 1
                If IsNumeric(Mid(Parts(X), Z, 1)) Then
                    Letter = Left(Parts(X), Z + (Left(Parts(X), 1) Like "[A-Za-z]"))
                    If IsNumeric(Letter) Then Letter = ""
                    NumberLeft = Mid(Left(Parts(X), InStr(Parts(X), "-") - 1), Z, 999)
                    NumberRight = Replace(Mid(Parts(X), InStr(Parts(X), "-") + 1), Letter, "")
                    Exit For
                End If
            Next Z
            For Z = NumberLeft To NumberRight
                ExpandedSeries = ExpandedSeries & ", " & Letter & Z
            Next Z
        Else
            ExpandedSeries = ExpandedSeries & ", " & Parts(X)
        End If
    Next X
    ExpandedSeries = Mid(ExpandedSeries, 3)
End Function

smozgur · May 29, 2024

If the letter is always the same, C in this case:

VBA Code:

Sub ConcatenateRefDesignator()
    Dim a, w
    Dim i&
    Dim c
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            c = 1
            If InStr(a(i, 2), "-") Then
                c = 1 - Evaluate(Replace(a(i, 2), "C", ""))
            End If
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), c)
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + c
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E3").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

Otherwise, either the 1st and 4th chars could be removed from the text, or simply a Regex implementation could be used as shown below to remove any chars except numbers and dash:

VBA Code:

Sub altConcatenateRefDesignator()
    Dim a, w
    Dim i&
    Dim c
    Dim r As Object
        a = Cells(2, 1).CurrentRegion
        Set r = CreateObject("VBScript.RegExp")
        r.Pattern = "\w(\d+)-\w(\d+)$"
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            c = 1
            If r.Test(a(i, 2)) Then
               c = Evaluate(r.Replace(a(i, 2), "$2-$1+1"))
            End If
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), c)
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + c
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E3").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

Another alternative could be Power Query:

Power Query:

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    AddColumn = Table.AddColumn(Source, "Custom", each if Text.Contains([REF DES], "-") then 
                        let 
                            Numbers = List.Transform(Text.ToList([REF DES]), each if Value.Is(Value.FromText(_), type number) or _ = "-" then _ else null),
                            Expr = Text.Combine(Numbers),
                            Result = 1 - Expression.Evaluate(Expr)
                        in
                            Result
                    else 1 
                ),
    GroupRows = Table.Group(AddColumn, {"CPN"}, {{"REF DES", each Text.Combine([REF DES], ","), type text}, {"Count", each List.Sum([Custom]), type number}})
in
    GroupRows

Macro to count hyphenated range

ukbulldog001

New Member

Attachments

Excel Facts

Snakehips

Well-known Member

ukbulldog001

New Member

Snakehips

Well-known Member

ukbulldog001

New Member

smozgur

BatCoder

Similar threads

Forum statistics

Share this page

Macro to count hyphenated range

ukbulldog001

New Member

Attachments

Excel Facts

Snakehips

Well-known Member

ukbulldog001

New Member

Snakehips

Well-known Member

ukbulldog001

New Member

smozgur

BatCoder

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock