VBA Script Columns to Text

[lefty38]

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]

 

[GTO]

All -- disregard post 15 i could not delete it

i am using the module

Sub oopsie_betterExample()

it works -- then breaks at larger than 3 rows returned --
...
red text is incorrect --- these are courses from data further down

Rick - I tried to use your script but got an out of range error - i could not resolve

ACK! Sorry about that; poor testing on my part.

I believe I duplicated your proposed data and tested with a modification to my second try (not having good luck am I?). I note just for clarity that you indicate a 94 ID count for 76900, but show 194 (which I went with).

Anyways, to (I ever so hope...) fix mine, change the bit below as shown:

  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<--- Change this loop to...
'        Keys(j) = Keys(j - 1)
'      Next
      
      For j = UBound(Keys) To n + AddlRows Step -1  '<---
        y = j - 1                                       '
        Do While Keys(y) = Empty                        '
          y = y - 1                                     '
        Loop                                            '
        Keys(j) = Keys(y)                               '
        If y = n Then                                   ' ... this mess, which seems to work.
          For m = y + 1 To j - 1                        ' (Don't forget to add Dim y As Long)
            Keys(m) = Keys(y)                           '
          Next                                          '
        Else                                            '
          Keys(y) = Empty                               '
        End If                                          '
      Next                                          '<---
      
    End If
    
  Next

I now return:

Excel Workbook
	D	E
1	Course	ID
2	33004	101
3	75031	101
4	75402	1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24
5	75402	25, 26, 27, 28, 29, 30
6	75735	101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115
7	75736	1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24
8	75736	25, 26, 27, 28
9	76900	601, 602, 603, 604, 605, 606, 607, 608, 609, 610, 611, 612, 613, 614, 615, 616, 617, 618, 619, 620, 621, 622, 623, 624
10	76900	625, 626, 627, 628, 629, 630, 631, 632, 633, 634, 635, 636, 637, 638, 639, 640, 641, 642, 643, 644, 645, 646, 647, 648
11	76900	649, 650, 651, 652, 653, 654, 655, 656, 657, 658, 659, 660, 661, 662, 663, 664, 665, 666, 667, 668, 669, 670, 671, 672
12	76900	673, 674, 675, 676, 677, 678, 679, 680, 681, 682, 683, 684, 685, 686, 687, 688, 689, 690, 691, 692, 693, 694, 695, 696
13	76900	697, 698, 699, 700, 701, 702, 703, 704, 705, 706, 707, 708, 709, 710, 711, 712, 713, 714, 715, 716, 717, 718, 719, 720
14	76900	721, 722, 723, 724, 725, 726, 727, 728, 729, 730, 731, 732, 733, 734, 735, 736, 737, 738, 739, 740, 741, 742, 743, 744
15	76900	745, 746, 747, 748, 749, 750, 751, 752, 753, 754, 755, 756, 757, 758, 759, 760, 761, 762, 763, 764, 765, 766, 767, 768
16	76900	769, 770, 771, 772, 773, 774, 775, 776, 777, 778, 779, 780, 781, 782, 783, 784, 785, 786, 787, 788, 789, 790, 791, 792
17	76900	793, 794
18	77517	123, 456
19	77581	10000
Sheet1

Excel 2010

Which is what you want, right?

On which line of code?

Hi Rick,

Code is treating Ids as numeric data type. So it is adding Ids instead of Concatenating...

Hi Rick and Ombir,

Rick, yours worked fine for me (no errors) as well. To Ombir's point, I disagree a tad. It doesn't add IDs, it does Concatenate them, but if the cells are General, at least for yours truly here, Excel thinks the three-digit numbers slammed together with the commas must mean we want a big number with thousands separators displayed. So for the first row for 76900, return becomes:

601,602,603,604,605,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000

...which is either six-hundred and one duovigintillion or maybe duodecillion depending on where one reads and neither of which I am likely to pronounce correctly.

I just tacked a space after the comma (in your code) and it Excel then understands it's a string.

Mick's code also seems to return correctly (I tried the second version).

I suspect yours or Mick's would be quicker running if the dataset was large enough, if for no other reason, mine creating multiple objects (the dictionaries).

Mark

 

[lefty38]

Rick,
your code gave me a Runtime Error '13' type mismatch at the red row

Sub CoursesAndIDs()
  Dim R As Long, X As Long, Cnt As Long, Current As Long
  Dim Data As Variant, Result() As String
  Data = Range("A2:B2").Resize(Cells(Rows.Count, "A").End(xlUp).Row - 1)
  ReDim Result(1 To UBound(Data), 1 To 2)
  For R = 1 To UBound(Data)
    If Data(R, 1) <> Current Then
      X = X + 1
      Cnt = 1
      [COLOR="#FF0000"]Current = Data(R, 1)[/COLOR]
      Result(X, 1) = Data(R, 1)
      Result(X, 2) = Data(R, 2)
    Else
      Cnt = Cnt + 1
      If Cnt > 24 Then
        X = X + 1
        Cnt = 1
        Result(X, 1) = Data(R, 1)
        Result(X, 2) = Data(R, 2)
      Else
        Result(X, 2) = Result(X, 2) & "," & Data(R, 2)
      End If
    End If
  Next
  Range("D1:E1") = Array("Course", "ID")
  Range("D2").Resize(UBound(Result), 2) = Result
End Sub

Ombir you script at post #8 is the script that works the best --

As it turns out - the space after the comma was causing an issue in the next process I have to perform
it turns out the next process had a character limit - which is usually about 24 ID numbers --
but it is easier to explain the 24 ID limit -- than the character limit - and breaking an ID number in half - when it reached maximum characters (hopefully I made sense)

removing the space in excel then caused the issue Mark referenced in post #21 1234,000,000,000,000 etc.

All -- thank you very much

David

Rick, if we need to pursue - we can -- I have no problem working to explore your script or any of the other great posters here

 

[GTO]

Hi David,

Glad you got something that suited your needs. I found mine gacks (no errors, but horrible return) if we randomly un-sort the input. Anyways, my logic was still faulty and I think this works including un-sorted.

Sub oopsie_betterExample_FixedIhope()
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 y                 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
      Debug.Print DICcourse.Item(arrValues(n, 1))(UBound(DICcourse.Item(arrValues(n, 1)))).Count
      
      If DICcourse.Item(arrValues(n, 1))(UBound(DICcourse.Item(arrValues(n, 1)))).Count = 24 Then
        DICids = DICcourse.Item(arrValues(n, 1))
        ReDim Preserve DICids(0 To UBound(DICids) + 1)
        Set DICids(UBound(DICids)) = CreateObject("Scripting.Dictionary")
        DICcourse.Item(arrValues(n, 1)) = DICids
      End If
      DICcourse.Item(arrValues(n, 1))(UBound(DICcourse.Item(arrValues(n, 1)))).Item(arrValues(n, 2)) = Empty
    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
        y = j - 1
        Do While Keys(y) = Empty
          y = y - 1
        Loop
        Keys(j) = Keys(y)
        If y = n Then
          For m = y + 1 To j - 1
            Keys(m) = Keys(y)
          Next
        Else
          Keys(y) = Empty
        End If
      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

A good day to all,

Mark

 

[Rick Rothstein]

Rick,
your code gave me a Runtime Error '13' type mismatch at the red row

Sub CoursesAndIDs()
  Dim R As Long, X As Long, Cnt As Long, Current As Long
  Dim Data As Variant, Result() As String
  Data = Range("A2:B2").Resize(Cells(Rows.Count, "A").End(xlUp).Row - 1)
  ReDim Result(1 To UBound(Data), 1 To 2)
  For R = 1 To UBound(Data)
    If Data(R, 1) <> Current Then
      X = X + 1
      Cnt = 1
      [COLOR="#FF0000"]Current = Data(R, 1)[/COLOR]
      Result(X, 1) = Data(R, 1)
      Result(X, 2) = Data(R, 2)
    Else
      Cnt = Cnt + 1
      If Cnt > 24 Then
        X = X + 1
        Cnt = 1
        Result(X, 1) = Data(R, 1)
        Result(X, 2) = Data(R, 2)
      Else
        Result(X, 2) = Result(X, 2) & "," & Data(R, 2)
      End If
    End If
  Next
  Range("D1:E1") = Array("Course", "ID")
  Range("D2").Resize(UBound(Result), 2) = Result
End Sub

Rick, if we need to pursue - we can -- I have no problem working to explore your script or any of the other great posters here

Run my code again and when the type mismatch error occurs again, click the Debug button and execute the following code line in the Immediate Window (press CTRL+G if you don't see it)...

? R

then look at your data and tell me what is in cell at the row number that it printed out (I am thinking it is going to be either a text string or an error message).

 

[Ombir]

Run my code again and when the type mismatch error occurs again, click the Debug button and execute the following code line in the Immediate Window (press CTRL+G if you don't see it)...

? R

then look at your data and tell me what is in cell at the row number that it printed out (I am thinking it is going to be either a text string or an error message).

Hi Rick,

Data is declared as Variant but Current as long data type. May be that's why mismatch occurs.

If we declare Current also as Variant or both Current and Data() as string then issue can be resolved.

 

[Rick Rothstein]

Hi Rick,

Data is declared as Variant but Current as long data type. May be that's why mismatch occurs.

That should not matter... Data is declared as a Variant so that it can hold all the cell values in a two-dimensional array... as long as the cells contain numeric values, assigning them to Current (declared as Long) will work... VB will coerce the numeric value to a Long in order to make the assignment, but if one of the cells does not contain a numeric value, VB will error out because it cannot be coerced to a Long.

 

[Ombir]

That should not matter... Data is declared as a Variant so that it can hold all the cell values in a two-dimensional array... as long as the cells contain numeric values, assigning them to Current (declared as Long) will work... VB will coerce the numeric value to a Long in order to make the assignment, but if one of the cells does not contain a numeric value, VB will error out because it cannot be coerced to a Long.

That's my point Rick. As long as cell contains numeric values then there is no issue but if cell contains text, then mismatch occurs because Variant/String will not compare against Long.

 

[Rick Rothstein]

That's my point Rick. As long as cell contains numeric values then there is no issue but if cell contains text, then mismatch occurs because Variant/String will not compare against Long.

I misread your intent given you responded to a quote in which I said, in part, "I am thinking it is going to be either a text string or an error message". What I want the OP to tell me is which of these it is or, if not one of those, exactly what he does have in the cell.

 

[lefty38]

Rick the error returned was
?R
567


Here is a list of that area on the excel file I am using
looks like when the column A runs into a Alpha Character - it errors


79204 2215062
79204 2215878
79204 2222774
79204 2313287
1S00029 219426
1S00029 1646469
1S00029 1871840

looks like your last few comments are correct
the course values are number or alpha characters

 

[Rick Rothstein]

Rick the error returned was
?R
567


Here is a list of that area on the excel file I am using
looks like when the column A runs into a Alpha Character - it errors


79204 2215062
79204 2215878
79204 2222774
79204 2313287
1S00029 219426
1S00029 1646469
1S00029 1871840

looks like your last few comments are correct
the course values are number or alpha characters

Yep! Those non-numbers are what did the code in. Changing the Current variable from Long to String should make the code work for you. Here is the full code with that modification in it...

Sub CoursesAndIDs()
  Dim R As Long, X As Long, Cnt As Long, Current As String
  Dim Data As Variant, Result() As String
  Data = Range("A2:B2").Resize(Cells(Rows.Count, "A").End(xlUp).Row - 1)
  ReDim Result(1 To UBound(Data), 1 To 2)
  For R = 1 To UBound(Data)
    If Data(R, 1) <> Current Then
      X = X + 1
      Cnt = 1
      Current = Data(R, 1)
      Result(X, 1) = Data(R, 1)
      Result(X, 2) = Data(R, 2)
    Else
      Cnt = Cnt + 1
      If Cnt > 24 Then
        X = X + 1
        Cnt = 1
        Result(X, 1) = Data(R, 1)
        Result(X, 2) = Data(R, 2)
      Else
        Result(X, 2) = Result(X, 2) & "," & Data(R, 2)
      End If
    End If
  Next
  Range("D1:E1") = Array("Course", "ID")
  Range("D2").Resize(UBound(Result), 2) = Result
End Sub