Need help with simple Macro to assist with children's colors!

[magitekkx]

Hi, to any Macro coders out there, I am trying to create a basic spreadsheet with a macro that does the following:

On the first tab, there are two columns. A1 reads "Name" and B1 reads "Code".
As an example, cell A2 contains "Billy Bob" and cell B2 contains the number 5236.

On the second tab, there are two columns. A1 is named "Code" and B1 is named "Favorite Color"
As an example, A2, A3, and A4 each have the value 5236. B2, B3, and B4 show "Blue", "Red", and "Green" respectively.

What I am trying to do on a third tab is to list all of the children's names. And then once the macro is run, it would show the child's name and their favorite color. The twist is that if the child has more than one favorite color (for example, Billy Bob was tied to 5236 which is tied to the three colors "Blue", "Red", and "Green", then Excel creates three rows for Billy Bob like this:

Bill Bob Blue
Billy Bob Red
Billy Bob Green

where Billy Bob is in column A, and the color is in Column B.

The reason I am having trouble is that the children might like 1, 2, 3, all the way up to 6 colors. Does anyone know how to program this? It would save hundreds of hours of manual entry.

Thank you!!!

 

[Jeffrey Mahoney]

I hope this works for you. You will need to put the names of your sheets in place of Sheet9, Sheet10, and Sheet11 in the red code section:

Are you going to create a button for this?

Sub GetColorsForKids()
  Dim OutR As Range
  Dim Cel As Range
  Dim CodeColorRng As Range
  Dim NameCodeRng As Range
  Dim CodeList() As Long
  Dim NameList() As String
  Dim R As Range
  Dim Tab1 As Worksheet
  Dim Tab2 As Worksheet
  Dim Tab3 As Worksheet
  Dim X As Long
  Dim Y As Long
  Dim cnCount As Long
  Dim CD As Long
  Dim LastCode As Long
  Dim LastY As Long
  
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  [COLOR=#ff0000]Set Tab1 = Sheets("Sheet9")
  Set Tab2 = Sheets("Sheet10")
  Set Tab3 = Sheets("Sheet11")[/COLOR]
  
  Set Cel = Tab1.Range("B2")
  Set R = Tab1.Range(Cel, Tab1.Cells(Tab1.Rows.Count, Cel.Column).End(xlUp))
  
  ReDim NameList(R.Rows.Count), CodeList(R.Rows.Count)
  
  'Get all the names and codes
  X = 0
  For Each Cel In R
    X = X + 1
    CodeList(X) = Cel.Value
    NameList(X) = Cel.Offset(0, -1).Value
  Next Cel
  cnCount = X
  
  Set Cel = Tab2.Range("A2")
  Set R = Tab2.Range(Cel, Tab2.Cells(Cells.Rows.Count, Cel.Column).End(xlUp))
  Set OutR = Tab3.Range("A1")
  Tab3.Range("A2:B10000").ClearContents
  
  X = 0
  For Each Cel In R         'Look at each code and color choice
    X = X + 1
    CD = Cel.Value          'Code
    If LastCode = CD Then
      Y = LastY
    Else
      For Y = 1 To CD
        If CD = CodeList(Y) Then    'Find the name for the code
          Exit For
        End If
      Next Y
    End If
    OutR.Offset(X, 0) = NameList(Y)             'Put the name in column A
    OutR.Offset(X, 1) = Cel.Offset(0, 1).Value  'Put the color in column B
    LastCode = CD
    LastY = Y
  Next Cel
  
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  
End Sub

 

[magitekkx]

Hi Jeffrey,

Thanks so much for your help. I named my tabs Sheet9, Sheet10, and Sheet11, but I am getting an error when I run your script.

The error is the following:

Run Time error 9:
Subscript is out of range

And the following line in your code is highlighted by the debugger:

If CD = CodeList(Y) Then 'Find the name for the code

My spreadsheet was organized as described above, but was there anything I needed to have in specific cells in Sheet11? Just the child's name? I don't have any named columns in that sheet.

Thanks!

 

[Jeffrey Mahoney]

Sorry. Please replace this line:
For Y = 1 To CD
to
For Y = 1 To cnCount

 

[magitekkx]

I made the change. When running the script, a new runtime error now popped up, saying subscript out of range and highlighting the following line:

OutR.Offset(X, 0) = NameList(Y) 'Put the name in column A

Any ideas?

 

[Jeffrey Mahoney]

That doesn't make sense. Do me a favor. Run it again. When it gives you the error, click debug. On the yellow line, hover your cursor over the letter Y, record that. Hover over the variable cnCount, record that.

Post the two values here.

 

[magitekkx]

Hi Jeff. Sure:

1. Y = 6
2. cnCount = 5

 

[Jeffrey Mahoney]

Please change these two lines:

OutR.Offset(X, 0).value = NameList(Y)             'Put the name in column A
OutR.Offset(X, 1).value = Cel.Offset(0, 1).Value  'Put the color in column B

To This:

[FONT=Verdana]OutR.Offset(X, 0).value = NameList(Y) [/FONT]
[FONT=Verdana]OutR.Offset(X, 1).value = Cel.Offset(0, 1) .value[/FONT]

I don't think it is going to fix the issue. I'm still looking

 

[Eric W]

Here's another macro to try:

Sub ColorsForKids()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim MyKids As Variant, MyCodes As Variant, Colors As Object
Dim i As Long, ctr As Long, w As Variant

' Identify the sheets to use
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    Set s3 = Sheets("Sheet3")
    
' Read the data from sheet1 and sheet2
    MyKids = s1.Range("A2:B" & s1.Cells(Rows.Count, "A").End(xlUp).Row).Value
    MyCodes = s2.Range("A2:B" & s2.Cells(Rows.Count, "A").End(xlUp).Row).Value
    
' Make a dictionary with all the codes, with the colors as the item ("Red, Blue, Green")
    Set Colors = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(MyCodes)
        If Colors.exists(MyCodes(i, 1)) Then
            Colors(MyCodes(i, 1)) = Colors(MyCodes(i, 1)) & "," & MyCodes(i, 2)
        Else
            Colors(MyCodes(i, 1)) = MyCodes(i, 2)
        End If
    Next i
    
' Count how may output rows we'll need, one per color per kid, minimum 1 per kid
    ctr = 0
    For i = 1 To UBound(MyKids)
        If Colors.exists(MyKids(i, 2)) Then
            ctr = ctr + UBound(Split(Colors(MyKids(i, 2)), ","))
        End If
        ctr = ctr + 1
    Next i
    
' Define the output table
    ReDim output(1 To ctr, 1 To 2)
    
' Go down the list of kids, add a row per color
    ctr = 1
    For i = 1 To UBound(MyKids)
        If Colors.exists(MyKids(i, 2)) Then
            For Each w In Split(Colors(MyKids(i, 2)), ",")
                output(ctr, 1) = MyKids(i, 1)
                output(ctr, 2) = w
                ctr = ctr + 1
            Next w
        Else
            output(ctr, 1) = MyKids(i, 1)
            ctr = ctr + 1
        End If
    Next i
    
' All done, clear the output sheet, add headers and data
    s3.Range("A:B").ClearContents
    s3.Range("A1:B1") = Array("Name", "Favorite Color")
    s3.Range("A2").Resize(UBound(output), 2) = output
            
End Sub

Change the sheet names to match your workbook.