Macro to count hyphenated range

ukbulldog001

ukbulldog001

New Member
Joined
Jul 8, 2015
Messages
26
Office Version
  1. 2016
Platform
  1. Windows
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.
CPNREF DESCPNREF DESCount
0654-9401-05C0010654-9401-05C001,C002,C074-C080,C011,C0125
0654-9401-05C0020656-9254-77C003,C008,C010,C013,C014,C015,C0177
0656-9254-77C0030654-9431-01C0051
0654-9401-05C074-C0800657-9051-06C0071
0654-9431-01C0050654-8411-04C0091
0657-9051-06C0070659-9111-54C018,C019,C0203
0656-9254-77C008
0654-8411-04C009
0656-9254-77C010
0654-9401-05C011
0654-9401-05C012
0656-9254-77C013
0656-9254-77C014
0656-9254-77C015
0656-9254-77C017
0659-9111-54C018
0659-9111-54C019
0659-9111-54C020



Below is the required result where the count should be 11 instead of 5
CPNREF DESCPNREF DESCount
0654-9401-05C0010654-9401-05C001,C002,C074-C080,C011,C01211
0654-9401-05C0020656-9254-77C003,C008,C010,C013,C014,C015,C0177
0656-9254-77C0030654-9431-01C0051
0654-9401-05C074-C0800657-9051-06C0071
0654-9431-01C0050654-8411-04C0091
0657-9051-06C0070659-9111-54C018,C019,C0203
0656-9254-77C008
0654-8411-04C009
0656-9254-77C010
0654-9401-05C011
0654-9401-05C012
0656-9254-77C013
0656-9254-77C014
0656-9254-77C015
0656-9254-77C017
0659-9111-54C018
0659-9111-54C019
0659-9111-54C020


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

Attachments

  • Result.JPG
    Result.JPG
    72.8 KB · Views: 6
  • Required result.JPG
    Required result.JPG
    72.2 KB · Views: 6

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
@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
 
Upvote 0
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
Click to expand...
@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.
CPNREF DESCPNREF DESCount
0654-9401-05C0010654-9401-05C001,C002,C074-C080,C011,C01211
0654-9401-05C0020656-9254-77C003,C008,C010,C013,C014,C015,C0177
0656-9254-77C0030654-9431-01C0051
0654-9401-05C074-C0800657-9051-06C0071
0654-9431-01C0050654-8411-04C055-C0601
0657-9051-06C0070659-9111-54C018,C019,C0203
0656-9254-77C008
0654-8411-04C055-C060
0656-9254-77C010
0654-9401-05C011
0654-9401-05C012
0656-9254-77C013
0656-9254-77C014
0656-9254-77C015
0656-9254-77C017
0659-9111-54C018
0659-9111-54C019
0659-9111-54C020
 
Upvote 0
@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
 
Upvote 0
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
Click to expand...
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
 
Upvote 0
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
 
Upvote 1
Solution
You must log in or register to reply here.

Similar threads

L
  • Question Question
Searchable Drop Down List in Data Validation without using VBA
Replies
0
Views
4K
Lenard
L
A
  • Question Question
Issues with Macro to import data from web, create pivot table & filter it based on a dynamic range
Replies
4
Views
1K
thatmarine
T
Alphacsulb
  • Question Question
Modify Formula with Macro
Replies
3
Views
662
Alphacsulb
Alphacsulb

Forum statistics

Threads
1,223,864
Messages
6,175,056
Members
452,607
Latest member
OoM_JaN

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top