VBA Script Columns to Text

L

lefty38

Board Regular
Joined
Oct 27, 2005
Messages
85
Hello
i am looking for a vb script that will convert "columns into text"

Criteria
at each course I need the ID to be placed into a comma separated text cell

function "transpose" only places the ID into separate columns --
this will not work

Like the desired output below

the one catch is the desired output can not be longer than 24 ID numbers wide



[TABLE="width: 258"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]

<tbody>
[TD="class: xl66"] Course
 [/TD]
[TD="class: xl66, width: 129"] ID [/TD]

[TD="class: xl67"] 33004 [/TD]
[TD="class: xl67"] 203212 [/TD]

[TD="class: xl67"] 75031 [/TD]
[TD="class: xl67"] 3075 [/TD]

[TD="class: xl67"] 75031 [/TD]
[TD="class: xl67"] 272278 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 7265 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 19701 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 22150 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 22949 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 29850 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 71350 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 73784 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 74850 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 90643 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 95914 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 113259 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 124119 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 130399 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 137030 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 242445 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 323047 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 417657 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 1087406 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 1440149 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 1771579 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 2054268 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl67"] 2194679 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl65"] 1661707
 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl65"] 1731981
 [/TD]

[TD="class: xl67"] 75402 [/TD]
[TD="class: xl65"] 1753502
 [/TD]

[TD="class: xl65"] 75735 [/TD]
[TD="class: xl65"] 1781611
 [/TD]

[TD="class: xl65"] 75735 [/TD]
[TD="class: xl65"] 1796959
 [/TD]

[TD="class: xl65"] 75735 [/TD]
[TD="class: xl65"] 2130582
 [/TD]

[TD="class: xl65"] 75735 [/TD]
[TD="class: xl65"] 2219557
 [/TD]

</tbody>




when the target output reaches 24 id numbers (stop)
repeat with the same course and get the next set of numbers -- if reaches 24 ID then
repeat again
New Course - start again

desired output[TABLE="width: 586"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]Course
[/TD]
[TD][/TD]
[TD]ID
[/TD]
[/TR]
[TR]
[TD="align: right"]33004[/TD]
[TD][/TD]
[TD]203212,[/TD]
[/TR]
[TR]
[TD="align: right"]75031
[/TD]
[TD][/TD]
[TD]3075,272278[/TD]
[/TR]
[TR]
[TD="align: right"]75402
[/TD]
[TD][/TD]
[TD]7265,19701,22150,29850,73784,74850,95914,113259,==> up to 24 ID numbers
[/TD]
[/TR]
[TR]
[TD="align: right"]75402[/TD]
[TD][/TD]
[TD]continue with remaining ID numbers 1731981,1753502,1771579,2054268,2194679[/TD]
[/TR]
[TR]
[TD="align: right"]75735[/TD]
[TD][/TD]
[TD]1781611,1796959,2130582,2219557
[/TD]
[/TR]
</tbody>[/TABLE]

and so on till the last row of data

the best situation -- would be putting each course and corresponding "text"
on the same row and on a new worksheet with the worksheet's name
the same as the course number

the next step in my process is to take the text and insert into another
program for further processing

and of course thank you in advance
[TABLE="width: 500"]
<tbody>[TR]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[/TR]
[TR]
[/TR]
[TR]
[/TR]
[TR]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Sort by date Sort by votes
Hi Lefty,

If you mean like:
Excel Workbook
ABCDE
1CourseID
23300420321233004203212
3750313075750313075,272278
475031272278754027265,19701,22150,22949,29850,71350,73784,74850,90643,95914,113259,124119,130399,137030,242445,323047,417657,1087406,1440149,1771579,2054268,2194679,1661707,1731981,1753502
5754027265757351781611
67540219701
77540222150
87540222949
97540229850
107540271350
117540273784
127540274850
137540290643
147540295914
1575402113259
1675402124119
1775402130399
1875402137030
1975402242445
2075402323047
2175402417657
22754021087406
23754021440149
24754021771579
25754022054268
26754022194679
27754021661707
28754021731981
29754021753502
30757351781611
Sheet1
Excel 2010

In a Standard Module:
Rich (BB code): 
Option Explicit

Sub example()
Dim LastCellWithData  As Range
Dim Cell              As Range
Dim DICcourse         As Object ' Scripting.Dictionary
Dim sTmp              As String
Dim Keys              As Variant
Dim Items             As Variant
Dim n                 As Long
  
  Set LastCellWithData = RangeFound(Sheet1.Range("A:A"))
  
  If LastCellWithData Is Nothing Then Exit Sub
  If LastCellWithData.Row< 2 Then Exit Sub
  
  Set DICcourse = CreateObject("Scripting.Dictionary")
  
  
  For Each Cell In Sheet1.Range(Sheet1.Range("A2"), LastCellWithData).Cells
    If Not DICcourse.Exists(Cell.Value) Then
      DICcourse.Item(Cell.Value) = CStr(Cell.Offset(, 1).Value) & ","
    Else
      sTmp = DICcourse.Item(Cell.Value)
      DICcourse.Item(Cell.Value) = sTmp & CStr(Cell.Offset(, 1).Value) & ","
    End If
  Next
  
  Keys = Application.Transpose(DICcourse.Keys)
  ReDim Preserve Keys(1 To UBound(Keys, 1), 1 To 2)
  Items = Application.Transpose(DICcourse.Items)
  
  For n = 1 To UBound(Keys, 1)
    Keys(n, 2) = Left$(Items(n, 1), Len(Items(n, 1)) - 1)
  Next
  
  'Change to Text to prevent Excel from "thinking" we're putting in big numbers with thousands seperators...
  Sheet1.Range("E2").Resize(UBound(Keys, 1)).NumberFormat = "@"
  
  Sheet1.Range("D2").Resize(UBound(Keys, 1), 2).Value = Keys
  
End Sub
  
Function RangeFound(SearchRange As Range, _
                    Optional ByVal FindWhat As String = "*", _
                    Optional StartingAfter As Range, _
                    Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
                    Optional LookAtWholeOrPart As XlLookAt = xlPart, _
                    Optional SearchRowCol As XlSearchOrder = xlByRows, _
                    Optional SearchUpDn As XlSearchDirection = xlPrevious, _
                    Optional bMatchCase As Boolean = False) As Range
    
    If StartingAfter Is Nothing Then
        Set StartingAfter = SearchRange.Cells(1)
    End If
    
    Set RangeFound = SearchRange.Find(What:=FindWhat, _
                                      After:=StartingAfter, _
                                      LookIn:=LookAtTextOrFormula, _
                                      LookAt:=LookAtWholeOrPart, _
                                      SearchOrder:=SearchRowCol, _
                                      SearchDirection:=SearchUpDn, _
                                      MatchCase:=bMatchCase)
End Function

Please Note: "Sheet1" refers to the sheet's CodeName.

Does that help?

Mark
 
Upvote 0
Try this for results in "C & D".
Code: 
[COLOR="Navy"]Sub[/COLOR] MG21Jun15
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = Cells(1).CurrentRegion.Resize(, 2)
ReDim nRay(1 To UBound(Ray, 1), 1 To 2)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
[COLOR="Navy"]If[/COLOR] Not .Exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
    ReDim nRay(1 To UBound(Ray, 1), 1 To 2)
    nRay(1, 1) = Ray(n, 1)
    nRay(1, 2) = Ray(n, 2)
    .Add Ray(n, 1), Array(nRay, 1, 1)
[COLOR="Navy"]Else[/COLOR]
    Q = .Item(Ray(n, 1))
        Q(2) = Q(2) + 1
            [COLOR="Navy"]If[/COLOR] Q(2) > 24 [COLOR="Navy"]Then[/COLOR]
                    Q(2) = 1: Q(1) = Q(1) + 1
                    Q(0)(Q(1), 1) = Ray(n, 1)
                    Q(0)(Q(1), 2) = Ray(n, 2)
            [COLOR="Navy"]Else[/COLOR]
                    Q(0)(Q(1), 1) = Ray(n, 1)
                    Q(0)(Q(1), 2) = Q(0)(Q(1), 2) & ", " & Ray(n, 2)
            [COLOR="Navy"]End[/COLOR] If
    .Item(Ray(n, 1)) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]


[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]For[/COLOR] p = 1 To .Item(K)(1)
        c = c + 1
        Cells(c, "D") = CStr(.Item(K)(0)(p, 1))
        Cells(c, "E") = CStr(.Item(K)(0)(p, 2))
    [COLOR="Navy"]Next[/COLOR] p
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Sub macro4()
Dim n As Long
Dim k As Long
Dim m As Long
Dim l As Long
Dim z As Long
Dim lastrow As Long
Dim lastrow1 As Long


With ActiveSheet
lastrow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Columns("A:A").Select
Selection.Copy
Columns("D:D").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("D1:D" & lastrow1).RemoveDuplicates Columns:=1, Header:=xlYes
With ActiveSheet
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
End With

For i = 2 To lastrow

Cells(i, 5).Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-4],RC[-1])"
Cells(i, 6).Select
ActiveCell.FormulaR1C1 = "=1+FLOOR(RC[-1]/24,1)"
Cells(i, 7).Select
ActiveCell.FormulaR1C1 = "=R[-1]C+R[-1]C[-2]"
Range("G2").Select
ActiveCell.FormulaR1C1 = "2"
Next

Cells(1, 8).Value = "Course"
Cells(1, 9).Value = "IDs"

For i = lastrow To 2 Step -1

Cells(i, 8).Value = Cells(i, 4).Value

k = Cells(i, 5).Value
m = Cells(i, 7).Value

If Cells(i, 6).Value = 1 Then

For j = 1 To k

'Cells(i, 9 + j).Value = Cells(m + j - 1, 2).Value

Cells(i, 9).Value = Cells(m + j - 1, 2).Value & " , " & Cells(i, 9).Value
Next

Else

l = Cells(i, 6).Value - 1

Range(Cells(i + 1, 8), Cells(i + 1, 100).Offset(l - 1, 0)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
For p = 1 To l
Cells(i + p, 8).Value = Cells(i, 4).Value
Next

For j = 1 To k
z = WorksheetFunction.Floor(j / 25, 1)

'Cells(i + z, 9 + j - z * 24).Value = Cells(m + j - 1, 2).Value

Cells(i + z, 9).Value = Cells(m + j - 1, 2).Value & " , " & Cells(i + z, 9).Value
Next


End If


Next

Columns("D:G").Select
Range("G1").Activate
Selection.Delete Shift:=xlToLeft
Range("E8").Select
Columns("E:E").EntireColumn.AutoFit
End Sub
 
Upvote 0
A Shorter alternative :-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG21Jun31
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Dup [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = Cells(1).CurrentRegion.Resize(, 2)
ReDim nray(1 To UBound(Ray, 1), 1 To 2)
    ReDim nray(1 To UBound(Ray, 1), 1 To 2)
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
 [COLOR="Navy"]If[/COLOR] Not Dup = Ray(n, 1) Or Num Mod 24 = 0 [COLOR="Navy"]Then[/COLOR]
        c = c + 1: Num = 0
  [COLOR="Navy"]End[/COLOR] If
    nray(c, 1) = Ray(n, 1)
    nray(c, 2) = nray(c, 2) & IIf(IsEmpty(nray(c, 2)), Ray(n, 2), ", " & Ray(n, 2))
    Num = Num + 1
    Dup = Ray(n, 1)
[COLOR="Navy"]Next[/COLOR]
Range("D1").Resize(c, 2) = nray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
@Mick:

Very Cool! :bow:

@Lefty:

I would use Mick's second example, but just as I caught that I had missed (from reading Mick's first example) the 24-numbers limitation, here was what I came up with as a fix...

Rich (BB code): 
Sub oopsie_betterExample()
Dim LastCellWithData  As Range
Dim DICcourse         As Object ' Scripting.Dictionary
Dim DICids()          As Object ' Scripting.Dictionary
Dim Keys              As Variant
Dim Items             As Variant
Dim arrValues         As Variant
Dim n                 As Long
Dim j                 As Long
Dim m                 As Long
Dim AddlRows          As Long
  
  Set LastCellWithData = RangeFound(Sheet1.Range("A:A"))
  
  If LastCellWithData Is Nothing Then Exit Sub
  If LastCellWithData.Row < 2 Then Exit Sub
  arrValues = Sheet1.Range(Sheet1.Range("A2"), LastCellWithData).Resize(, 2).Value
  
  Set DICcourse = CreateObject("Scripting.Dictionary")
  
  For n = 1 To UBound(arrValues)
    If Not DICcourse.Exists(arrValues(n, 1)) Then
      ReDim DICids(0 To 0)
      Set DICids(0) = CreateObject("Scripting.Dictionary")
      DICids(0).Item(arrValues(n, 2)) = Empty
      DICcourse.Item(arrValues(n, 1)) = DICids
    Else
      If DICids(UBound(DICids)).Count = 24 Then
        ReDim Preserve DICids(0 To UBound(DICids) + 1)
        Set DICids(UBound(DICids)) = CreateObject("Scripting.Dictionary")
      End If
      DICids(UBound(DICids)).Item(arrValues(n, 2)) = Empty
      DICcourse.Item(arrValues(n, 1)) = DICids
    End If
  Next
  
  Keys = DICcourse.Keys
  Items = DICcourse.Items
    
  For n = UBound(Keys) To LBound(Keys) Step -1
    If UBound(Items(n)) > 0 Then
      AddlRows = UBound(Items(n)) - LBound(Items(n))
      ReDim Preserve Keys(0 To (UBound(Keys) + AddlRows))
      For j = UBound(Keys) To n + AddlRows Step -1
        Keys(j) = Keys(j - 1)
      Next
    End If
  Next
  
  Keys = Application.Transpose(Keys)
  ReDim Preserve Keys(1 To UBound(Keys), 1 To 2)
  
  j = 0
  
  For n = LBound(Items) To UBound(Items)
    For m = LBound(Items(n)) To UBound(Items(n))
      j = j + 1
      Keys(j, 2) = Join(Items(n)(m).Keys, ", ")
    Next
  Next
  
  Sheet1.Range("D2").Resize(UBound(Keys, 1), 2).Value = Keys
  
End Sub
  
Function RangeFound(SearchRange As Range, _
                    Optional ByVal FindWhat As String = "*", _
                    Optional StartingAfter As Range, _
                    Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
                    Optional LookAtWholeOrPart As XlLookAt = xlPart, _
                    Optional SearchRowCol As XlSearchOrder = xlByRows, _
                    Optional SearchUpDn As XlSearchDirection = xlPrevious, _
                    Optional bMatchCase As Boolean = False) As Range
    
    If StartingAfter Is Nothing Then
        Set StartingAfter = SearchRange.Cells(1)
    End If
    
    Set RangeFound = SearchRange.Find(What:=FindWhat, _
                                      After:=StartingAfter, _
                                      LookIn:=LookAtTextOrFormula, _
                                      LookAt:=LookAtWholeOrPart, _
                                      SearchOrder:=SearchRowCol, _
                                      SearchDirection:=SearchUpDn, _
                                      MatchCase:=bMatchCase)
End Function

Mark
 
Upvote 0
Hi Lefty,

If you're interested, here is another approach:

Code: 
Sub lefty()
Dim i       As Long
Dim j       As Long
Dim dict    As Object
Dim Rng     As Range
Dim cell    As Range

Set Rng = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
Set dict = CreateObject("scripting.dictionary")

With dict

For Each cell In Rng
    If Not .Exists(cell.Value & "_") Then
        i = 0
        txt = CStr(cell.Offset(, 1).Value)
        .Add cell.Value & "_", Array(txt, i + 1)
    Else
        Q = .Item(cell.Value & "_")
        Q(1) = Q(1) + 1
        If Q(1) = 24 Then
            j = j + 1
            nkey = cell.Value & "_" & j
            .Key(cell.Value & "_") = nkey
            .Item(nkey) = Q(0) & "," & CStr(cell.Offset(, 1).Value)
        Else
            Q(0) = Q(0) & "," & CStr(cell.Offset(, 1).Value)
            .Item(cell.Value & "_") = Q
        End If
    End If
Next

Range("D1:E1") = Array("COURSE", "ID")
i = 2

For Each K In .keys()
    Cells(i, 4) = left(K, InStr(1, K, "_") - 1)
    Cells(i, 5).NumberFormat = "@"
    Cells(i, 5).Value = .Item(K)
    i = i + 1
Next

End With
End Sub
 
Upvote 0
MickG said:
A Shorter alternative :-
Code: 
[COLOR=Navy]Sub[/COLOR] MG21Jun31
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, Dup [COLOR=Navy]As[/COLOR] [COLOR=Navy]String,[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Ray [COLOR=Navy]As[/COLOR] Variant, Num [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
Ray = Cells(1).CurrentRegion.Resize(, 2)
ReDim nray(1 To UBound(Ray, 1), 1 To 2)
    ReDim nray(1 To UBound(Ray, 1), 1 To 2)
[COLOR=Navy]For[/COLOR] n = 1 To UBound(Ray, 1)
 [COLOR=Navy]If[/COLOR] Not Dup = Ray(n, 1) Or Num Mod 24 = 0 [COLOR=Navy]Then[/COLOR]
        c = c + 1: Num = 0
  [COLOR=Navy]End[/COLOR] If
    nray(c, 1) = Ray(n, 1)
    nray(c, 2) = nray(c, 2) & IIf(IsEmpty(nray(c, 2)), Ray(n, 2), ", " & Ray(n, 2))
    Num = Num + 1
    Dup = Ray(n, 1)
[COLOR=Navy]Next[/COLOR]
Range("D1").Resize(c, 2) = nray
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
Click to expand...


Mick,

There seems to be some problem with this method as its not grouping correctly for below data set.

AB
CourseID

<colgroup><col style="width: 25pxpx"><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]

[TD="align: center"]2[/TD]
[TD="align: right"]33004[/TD]
[TD="align: right"]203212[/TD]

[TD="align: center"]3[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]3075[/TD]

[TD="align: center"]4[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]272278[/TD]

[TD="align: center"]5[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]7265[/TD]

[TD="align: center"]6[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]19701[/TD]

[TD="align: center"]7[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]22150[/TD]

[TD="align: center"]8[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]22949[/TD]

[TD="align: center"]9[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]29850[/TD]

[TD="align: center"]10[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]71350[/TD]

[TD="align: center"]11[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]73784[/TD]

[TD="align: center"]12[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]74850[/TD]

[TD="align: center"]13[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]90643[/TD]

[TD="align: center"]14[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]95914[/TD]

[TD="align: center"]15[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]113259[/TD]

[TD="align: center"]16[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]124119[/TD]

[TD="align: center"]17[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]130399[/TD]

[TD="align: center"]18[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]137030[/TD]

[TD="align: center"]19[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]242445[/TD]

[TD="align: center"]20[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]323047[/TD]

[TD="align: center"]21[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]417657[/TD]

[TD="align: center"]22[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1087406[/TD]

[TD="align: center"]23[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1440149[/TD]

[TD="align: center"]24[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1771579[/TD]

[TD="align: center"]25[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]2054268[/TD]

[TD="align: center"]26[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]2194679[/TD]

[TD="align: center"]27[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1661707[/TD]

[TD="align: center"]28[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1731981[/TD]

[TD="align: center"]29[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1753502[/TD]

[TD="align: center"]30[/TD]
[TD="align: right"]75735[/TD]
[TD="align: right"]1781611[/TD]

[TD="align: center"]31[/TD]
[TD="align: right"]75735[/TD]
[TD="align: right"]1796959[/TD]

[TD="align: center"]32[/TD]
[TD="align: right"]75735[/TD]
[TD="align: right"]2130582[/TD]

[TD="align: center"]33[/TD]
[TD="align: right"]75735[/TD]
[TD="align: right"]2219557[/TD]

[TD="align: center"]34[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]7265[/TD]

[TD="align: center"]35[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]19701[/TD]

[TD="align: center"]36[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]22150[/TD]

[TD="align: center"]37[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]22949[/TD]

[TD="align: center"]38[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]29850[/TD]

[TD="align: center"]39[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]71350[/TD]

[TD="align: center"]40[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]73784[/TD]

[TD="align: center"]41[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]74850[/TD]

[TD="align: center"]42[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]90643[/TD]

[TD="align: center"]43[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]95914[/TD]

[TD="align: center"]44[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]113259[/TD]

[TD="align: center"]45[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]124119[/TD]

[TD="align: center"]46[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]130399[/TD]

[TD="align: center"]47[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]137030[/TD]

[TD="align: center"]48[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]242445[/TD]

[TD="align: center"]49[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]323047[/TD]

[TD="align: center"]50[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]417657[/TD]

[TD="align: center"]51[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1087406[/TD]

[TD="align: center"]52[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1440149[/TD]

[TD="align: center"]53[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1771579[/TD]

[TD="align: center"]54[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]2054268[/TD]

[TD="align: center"]55[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]2194679[/TD]

[TD="align: center"]56[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1661707[/TD]

[TD="align: center"]57[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1731981[/TD]

[TD="align: center"]58[/TD]
[TD="align: right"]75402[/TD]
[TD="align: right"]1753502[/TD]

[TD="align: center"]59[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]7265[/TD]

[TD="align: center"]60[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]19701[/TD]

[TD="align: center"]61[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]22150[/TD]

[TD="align: center"]62[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]22949[/TD]

[TD="align: center"]63[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]29850[/TD]

[TD="align: center"]64[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]71350[/TD]

[TD="align: center"]65[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]73784[/TD]

[TD="align: center"]66[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]74850[/TD]

[TD="align: center"]67[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]90643[/TD]

[TD="align: center"]68[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]95914[/TD]

[TD="align: center"]69[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]113259[/TD]

[TD="align: center"]70[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]124119[/TD]

[TD="align: center"]71[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]130399[/TD]

[TD="align: center"]72[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]137030[/TD]

[TD="align: center"]73[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]242445[/TD]

[TD="align: center"]74[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]323047[/TD]

[TD="align: center"]75[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]417657[/TD]

[TD="align: center"]76[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]1087406[/TD]

[TD="align: center"]77[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]1440149[/TD]

[TD="align: center"]78[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]1771579[/TD]

[TD="align: center"]79[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]2054268[/TD]

[TD="align: center"]80[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]2194679[/TD]

[TD="align: center"]81[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]1661707[/TD]

[TD="align: center"]82[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]1731981[/TD]

[TD="align: center"]83[/TD]
[TD="align: right"]75031[/TD]
[TD="align: right"]1753502[/TD]

</tbody>
Sheet3​
 
Upvote 0
GTO said:
@Mick:

Very Cool! :bow:

@Lefty:

I would use Mick's second example, but just as I caught that I had missed (from reading Mick's first example) the 24-numbers limitation, here was what I came up with as a fix...

Rich (BB code): 
Sub oopsie_betterExample()
Dim LastCellWithData  As Range
Dim DICcourse         As Object ' Scripting.Dictionary
Dim DICids()          As Object ' Scripting.Dictionary
Dim Keys              As Variant
Dim Items             As Variant
Dim arrValues         As Variant
Dim n                 As Long
Dim j                 As Long
Dim m                 As Long
Dim AddlRows          As Long
  
  Set LastCellWithData = RangeFound(Sheet1.Range("A:A"))
  
  If LastCellWithData Is Nothing Then Exit Sub
  If LastCellWithData.Row < 2 Then Exit Sub
  arrValues = Sheet1.Range(Sheet1.Range("A2"), LastCellWithData).Resize(, 2).Value
  
  Set DICcourse = CreateObject("Scripting.Dictionary")
  
  For n = 1 To UBound(arrValues)
    If Not DICcourse.Exists(arrValues(n, 1)) Then
      ReDim DICids(0 To 0)
      Set DICids(0) = CreateObject("Scripting.Dictionary")
      DICids(0).Item(arrValues(n, 2)) = Empty
      DICcourse.Item(arrValues(n, 1)) = DICids
    Else
      If DICids(UBound(DICids)).Count = 24 Then
        ReDim Preserve DICids(0 To UBound(DICids) + 1)
        Set DICids(UBound(DICids)) = CreateObject("Scripting.Dictionary")
      End If
      DICids(UBound(DICids)).Item(arrValues(n, 2)) = Empty
      DICcourse.Item(arrValues(n, 1)) = DICids
    End If
  Next
  
  Keys = DICcourse.Keys
  Items = DICcourse.Items
    
  For n = UBound(Keys) To LBound(Keys) Step -1
    If UBound(Items(n)) > 0 Then
      AddlRows = UBound(Items(n)) - LBound(Items(n))
      ReDim Preserve Keys(0 To (UBound(Keys) + AddlRows))
      For j = UBound(Keys) To n + AddlRows Step -1
        Keys(j) = Keys(j - 1)
      Next
    End If
  Next
  
  Keys = Application.Transpose(Keys)
  ReDim Preserve Keys(1 To UBound(Keys), 1 To 2)
  
  j = 0
  
  For n = LBound(Items) To UBound(Items)
    For m = LBound(Items(n)) To UBound(Items(n))
      j = j + 1
      Keys(j, 2) = Join(Items(n)(m).Keys, ", ")
    Next
  Next
  
  Sheet1.Range("D2").Resize(UBound(Keys, 1), 2).Value = Keys
  
End Sub
  
Function RangeFound(SearchRange As Range, _
                    Optional ByVal FindWhat As String = "*", _
                    Optional StartingAfter As Range, _
                    Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
                    Optional LookAtWholeOrPart As XlLookAt = xlPart, _
                    Optional SearchRowCol As XlSearchOrder = xlByRows, _
                    Optional SearchUpDn As XlSearchDirection = xlPrevious, _
                    Optional bMatchCase As Boolean = False) As Range
    
    If StartingAfter Is Nothing Then
        Set StartingAfter = SearchRange.Cells(1)
    End If
    
    Set RangeFound = SearchRange.Find(What:=FindWhat, _
                                      After:=StartingAfter, _
                                      LookIn:=LookAtTextOrFormula, _
                                      LookAt:=LookAtWholeOrPart, _
                                      SearchOrder:=SearchRowCol, _
                                      SearchDirection:=SearchUpDn, _
                                      MatchCase:=bMatchCase)
End Function

Mark
Click to expand...

Hi Mark,

This code is not giving correct output for the sample data that I posted in above post no 9. Please Check.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,236
Messages
6,170,915
Members
452,366
Latest member
TePunaBloke

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