VBA code to move multiple values associated with one student to specific cell

[JLGUZMAN]

Hello all,
So I am just starting to venture into Excel VBA and I have been able to patch some things together with the help of this site, but I am now stumped as to how to resolve this one issue. I have a large report that has the workshop segments for a specific student registered that semester listed under their registration information and I need it to be associated with that students record for that specific semester and course. There is also the added issue that it is coming up with duplicates for each of the workshops for that one student, and there is not rhyme or reason as to how many times it duplicates it. I have over 500 students each semester and need to get these reports out to instructors on a timely basis at the start of the semester.

Site ID	Status	Report Month	Type Of Form	Training Date	Course ID	Student ID	Workshops:
SF08891	Rejected	May	Reg	4/15/2018	S088456	W008546	Need workshops that correspond to this student to be moved into Cell H3 without duplications.
(013) Harm Reduction
(013) Harm Reduction
(013) Harm Reduction
(201) Writing Skills
(201) Writing Skills
(201) Writing Skills
SF08564	Rejected	May	Reg	4/15/2018	S054685	W004685	Need workshops that correspond to this student to be moved into Cell H9 without duplications.
(013) Harm Reduction
(013) Harm Reduction
(201) Writing Skills
(201) Writing Skills
(201) Writing Skills
(201) Writing Skills

<tbody>
</tbody>

 

[igold]

Hi JLGUZMAN,

Welcome to the MrExcel board.

If what you have posted is the before (I have no idea where cell H3 is), then you might want to post the after. Meaning if we could see what your expected result is (with column and row labels), it would make this a lot easier...

 

[JLGUZMAN]

Hello,
Sorry about that. I am new to this whole bloging for help thing.

Here is the image of what I am looking for. The top is the before and the bottom is after. Thank you.

	A	B	C	D	E	F	G	H
1	Site ID	Status	Month	Type Of Form	Training Date	Course ID	Student ID	Workshops:
2	SF08891	Rejected	May	Reg	4/15/2018	S088456	W008546	Need workshops that correspond to this student to be moved into Cell H3 without duplications.
3	(013) Harm Reduction
4	(013) Harm Reduction
5	(013) Harm Reduction
6	(201) Writing Skills
7	(201) Writing Skills
8	(201) Writing Skills
9	SF08564	Rejected	May	Reg	4/15/2018	S054685	W004685	Need workshops that correspond to this student to be moved into Cell H9 without duplications.
10	(013) Harm Reduction
11	(013) Harm Reduction
12	(201) Writing Skills
13	(201) Writing Skills
14	(201) Writing Skills
15	(201) Writing Skills
	A	B	C	D	E	F	G	H
1	Site ID	Status	Month	Type Of Form	Training Date	Course ID	Student ID	Workshops:
2	SF08891	Rejected	May	Reg	4/15/2018	S088456	W008546	(013) Harm Reduction, (201) Writing Skills
3	SF08564	Rejected	May	Reg	4/15/2018	S054685	W004685	(013) Harm Reduction, (201) Writing Skills

<colgroup><col width="64" style="width: 48pt;"> <col width="100" style="width: 75pt; mso-width-source: userset; mso-width-alt: 3657;"> <col width="71" style="width: 53pt; mso-width-source: userset; mso-width-alt: 2596;"> <col width="57" style="width: 43pt; mso-width-source: userset; mso-width-alt: 2084;"> <col width="68" style="width: 51pt; mso-width-source: userset; mso-width-alt: 2486;"> <col width="80" style="width: 60pt; mso-width-source: userset; mso-width-alt: 2925;"> <col width="92" style="width: 69pt; mso-width-source: userset; mso-width-alt: 3364;"> <col width="97" style="width: 73pt; mso-width-source: userset; mso-width-alt: 3547;"> <col width="235" style="width: 176pt; mso-width-source: userset; mso-width-alt: 8594;"> <tbody> </tbody>

 

[Peter_SSs]

Welcome to the MrExcel board!

Try this in a copy of your workbook.

Sub Workshops()
  Dim rA As Range, c As Range
  Dim d As Object
  Dim lr As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  lr = Range("A" & Rows.Count).End(xlUp).Row
  Application.ScreenUpdating = False
  For Each rA In Range("G2:G" & lr).SpecialCells(xlBlanks).Areas
    d.RemoveAll
    For Each c In Intersect(rA.EntireRow, Columns("A"))
      d(c.Value) = Empty
    Next c
    rA.Cells(0, 2).Value = Join(d.Keys, ", ")
  Next rA
  Range("H2:H" & lr).SpecialCells(xlBlanks).EntireRow.Delete
  Application.ScreenUpdating = True
End Sub

 

[JLGUZMAN]

Thank you so much. This worked great. I do have one question as I am still learning VBA. If I tried changing the reference column to F by changing "For Each rA In Range("F2:F" & lr).SpecialCells(xlBlanks).Areas" but now it runs and deletes everything in the workbook. Course ID's are also unique and do not duplicate. Am I adjusting the code incorrectly? Thanks again.

 

[Peter_SSs]

Thank you so much. This worked great.

You're welcome, that's great!

I do have one question as I am still learning VBA. If I tried changing the reference column to F by changing "For Each rA In Range("F2:F" & lr).SpecialCells(xlBlanks).Areas" but now it runs and deletes everything in the workbook. Course ID's are also unique and do not duplicate. Am I adjusting the code incorrectly? Thanks again.

The reason that everything (except row 1) was deleted after your change stems from the unchanged line

rA.Cells(0, 2).Value = Join(d.Keys, ", ")

This line writes the workshop data 1 column to the right of the referenced column you changed. That is, it would have over-written the student ID's and then when it came to the line ..

Range("H2:H" & lr).SpecialCells(xlBlanks).EntireRow.Delete

.. all cells would still be blank, and hence deleted.
Try changing the column ref from G to F, but also change that red 2 to 3 and see how it goes.