Combining rows that meet a criteria

[MeghanE]

Morning!
I am wanting to combine rows into a single cell if they meet a certain criteria. I have found an addin that does it for me BUT is only available on a trial basis.

I have 2 sets of data, ID numbers and modules trained in. I want to generate a list to tell me what module each person has completed.

My data looks something like this (very simplified version)...

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

	A	B
1	ID NUMBER	MODULE
2	2301110069085	Vegetable
3	2906160031088	Chicken
4	3004145292081	Fruit
5	2301110069085	Chicken
6	2906160031088	Fruit
7	3004145292081	Vegetable

<tbody>
</tbody>

[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
But I would like to be able to work with it like this...

[TABLE="width: 0"]
<tbody>[TR]
[TD][/TD]
[TD]C[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]ID NUMBER[/TD]
[TD]MODULES[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]2301110069085[/TD]
[TD]Vegetable; Chicken[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]2906160031088[/TD]
[TD]Chicken; Fruit[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]3004145292081[/TD]
[TD]Fruit; Vegetable[/TD]
[/TR]
</tbody>[/TABLE]

Any suggestions? The best I can come up with myself is combining and "IF" and "CONCATENATE" formula but I only get the 1st module showing in the list in column D.

THANKS!!!

 

[Fishboy]

Hi MeghanE,

I am not sure if VBA is an option for you, however the following code will do what you describe:

Sub UpdateModules()
' Defines variables
Dim CellA As Range, CellC As Range, aRange As Range, cRange As Range, FindString As String


' Defines LastRowA as the last row of data in column A
LastRowA = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
' Defines LastRowC as the last row of data in column C
LastRowC = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row


' Sets aRange as A2 to the last row of A
Set aRange = Range("A2:A" & LastRowA)
' Sets cRange as C2 to the last row of C
Set cRange = Range("C2:C" & LastRowC)


' For each cell in cRange
For Each CellC In cRange
    ' Update variable FindString with the cell value
    FindString = CellC.Value
    ' For each cell in aRange
    For Each CellA In aRange
        ' If the cell value matches the desired FindString then...
        If CellA.Value = FindString Then
            ' Append the value of the adjacent cell in column D with the adjacent value from column B
            CellC.Offset(0, 1).Value = CellC.Offset(0, 1).Value & CellA.Offset(0, 1).Value & "; "
        End If
    ' Check next cell in column A
    Next CellA
    ' If the last 2 characters of the cell in column D is "; " then...
    If Right(CellC.Offset(0, 1), 2) = "; " Then
        ' Shorten the length of the cell value by removing the trailing "; "
        CellC.Offset(0, 1).Value = Left(CellC.Offset(0, 1).Value, Len(CellC.Offset(0, 1)) - 2)
    End If
' Check next cell in column C
Next CellC


End Sub

 

[AlanY]

try this, no of modulus set to 5, adjust to suit

Excel 2012
	A	B	C	D	E	F	G	H	I	J
1	ID NUMBER	MODULE		ID NUMBER	MODULE1	MODULE2	MODULE3	MODULE4	MODULE5	MODULES
2	2301110069085	Vegetable		2301110069085	Vegetable	Chicken				Vegetable; Chicken
3	2906160031088	Chicken		2906160031088	Chicken	Fruit				Chicken; Fruit
4	3004145292081	Fruit		3004145292081	Fruit	Vegetable				Fruit; Vegetable
5	2301110069085	Chicken
6	2906160031088	Fruit
7	3004145292081	Vegetable
Sheet7

Cell Formulas
Range	Formula
J2	=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(E2&" "&F2&" "&G2&" "&H2&" "&I2,", ","@"))," ","; "),"@",", ")
E2	{=IFERROR(INDEX($B$2:$B$7,SMALL(IF($A$2:$A$7=$D2,ROW($A$2:$A$7)-ROW($D$2)+1),COLUMNS($E2:E2))),"")}
Press CTRL+SHIFT+ENTER to enter array formulas.

 

[bhos123]

1> sort using column A
2> C2=if(A2=A1,0,1) , will identify first row for each ID
3>find max number of modules for any particular ID in the data(assuming it is 3)
4> D2=B2, E2=if(c3=0,B3,"") , F2=if(c4+c3=0,B4,"") , G2=if(c5+c4+c3=0,B5,"")
5> filter only the column C=1

Hope this works.

[/QUOTE]

 

[Arvapallyk]

Hello Meghan Try this Code.

Sub MyConsol()
Range("E:E").ClearContents
Dim i As Integer, j As Integer, LR As Integer
LR = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LR
    For j = i + 1 To LR
        If Cells(i, 1) = Cells(j, 1) Then
            If i <> j Then
            Cells(i, 5) = Cells(i, 3) & ";" & Cells(j, 3)
            End If
        End If
    Next j
Next i
End Sub

 

[Arvapallyk]

[TABLE="width: 453"]
<colgroup><col><col><col><col></colgroup><tbody>[TR]
[TD]ID NUMBER[/TD]
[TD] [/TD]
[TD]MODULE[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]2301110069085[/TD]
[TD] [/TD]
[TD]Vegetable[/TD]
[TD]Vegetable;Chicken;Banana;[/TD]
[/TR]
[TR]
[TD]2906160031088[/TD]
[TD] [/TD]
[TD]Chicken[/TD]
[TD]Chicken;Fruit;Apple;[/TD]
[/TR]
[TR]
[TD]3004145292081[/TD]
[TD] [/TD]
[TD]Fruit[/TD]
[TD]Fruit;Vegetable;Orange;[/TD]
[/TR]
[TR]
[TD]2301110069085[/TD]
[TD] [/TD]
[TD]Chicken[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]2906160031088[/TD]
[TD] [/TD]
[TD]Fruit[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]3004145292081[/TD]
[TD] [/TD]
[TD]Vegetable[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]2301110069085[/TD]
[TD] [/TD]
[TD]Banana[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]2906160031088[/TD]
[TD] [/TD]
[TD]Apple[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]3004145292081[/TD]
[TD] [/TD]
[TD]Orange[/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]

Sub MyColnsol_2()
Range("D:D").ClearContents
Dim i As Integer, j As Integer, LR As Integer
LR = Cells(Rows.Count, 1).End(xlUp).Row
MyText = ""
For i = 2 To LR
Cells(2, 1).Select
Do
If Cells(i, 1) = ActiveCell And i <= ActiveCell.Row Then
MyText = MyText & ActiveCell.Offset(0, 2) & ";"
ElseIf i > ActiveCell.Row And Cells(i, 1) = ActiveCell Then
GoTo LastLine
End If
ActiveCell.Offset(1, 0).Select
Loop While ActiveCell <> ""
Cells(i, 4) = MyText
MyText = ""
LastLine:
Next i
End Sub

 

[hiker95]

MeghanE,

Here is another macro solution for you to consider.

Sample raw data in the active worksheet:

Excel 2007
	A	B	C	D
1	ID NUMBER	MODULE
2	2301110069085	Vegetable
3	2906160031088	Chicken
4	3004145292081	Fruit
5	2301110069085	Chicken
6	2906160031088	Fruit
7	3004145292081	Vegetable
8
Sheet1

And, after the macro in the active worksheet:

Excel 2007
	A	B	C	D
1	ID NUMBER	MODULE	ID NUMBER	MODULES
2	2301110069085	Vegetable	2301110069085	Vegetable; Chicken
3	2906160031088	Chicken	2906160031088	Chicken; Fruit
4	3004145292081	Fruit	3004145292081	Fruit; Vegetable
5	2301110069085	Chicken
6	2906160031088	Fruit
7	3004145292081	Vegetable
8
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub CombineData()
' hiker95, 05/09/2016, ME940028
Dim rng As Range, r As Range
Set rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For Each r In rng
    If Not .Exists(r.Value) Then
      .Add r.Value, r.Offset(, 1).Value
    Else
      .Item(r.Value) = .Item(r.Value) & "; " & r.Offset(, 1).Value
    End If
  Next
  Range("C1").Resize(, 2).Value = Array("ID NUMBER", "MODULES")
  Range("C2").Resize(.Count, 2) = Application.Transpose(Array(.keys, .Items))
  For Each r In rng.Offset(, 2)
    If Not r = vbEmpty Then
      r = "'" & r
    End If
  Next r
End With
Cells.EntireColumn.AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the CombineData macro.