Tricky one, Changing vertical list to horizontal list...

[N1ck9141]

Hi I have a vertical list, setup as below:



Emails
Task
Groups


Email 1
Task 1
Group 1


Email 2
Task 2
Group 2


Email 3
Task 3
Group 3


Email 4
Task 4
Group 1


Email 5
Task 5
Group 1


Email 6
Task 6
Group 4


Email 7
Task 7
Group 2


Email 8
Task 8
Group 3




etc. There is always a new line per email address and the groups that the email addresses belong to are all over the place. i would like it to convert to look look like the below



Email 1, Email 4, Email 5

Group 1
Task 1
Task 4
Task 5


Email 2, Email 7

Group 2
Task 2
Task 7



Email 3, Email 8

Group 3
Task 3
Task 8




So all the address linked to group 1 will be in column "A" a single cell separated by comma
the groups itself in column "B"
and then the tasks in there own cell each going from column "C" going horizontally to however many are require.

can anyone assist with this?

[snb]

Don't change the data, use filters.

[N1ck9141]

No i need to change the data because the changed data is then used for something else, and the original is used for something else once again. (other macros already in place and working)

[GTO]

Greetings Nick,

Does this help?

In a Standard Module:


Option Explicit

Sub example()
Dim DIC As Object ' Scripting.Dictionary
Dim Cell As Range
Dim Range2Search As Range
Dim arrValues As Variant
Dim arrTmp As Variant
Dim lElement As Long
Dim RowIndex As Long
Dim ColumnIndex As Long

'// Note: Worksheet's default CodeName used. //
With Sheet1
Set Cell = RangeFound(.Range(.Cells(2, "C"), .Cells(.Rows.Count, "C")))
If Cell Is Nothing Then
MsgBox "Nothing found in the ""Group"" column. Exiting...", vbInformation, vbNullString
Exit Sub
Else
Set Range2Search = .Range(.Cells(2, "C"), Cell)
If IsArray(Range2Search.Value) Then
arrValues = Range2Search.Value
Else
MsgBox "You only have one record, copy/paste...", vbInformation, vbNullString
Exit Sub
End If
End If
End With

Set DIC = CreateObject("Scripting.Dictionary")

For lElement = 1 To UBound(arrValues)
DIC.Item(arrValues(lElement, 1)) = Empty
Next

arrValues = Range2Search.Offset(, -2).Resize(, 3).Value

For lElement = 1 To UBound(arrValues)
If IsEmpty(DIC.Item(arrValues(lElement, 3))) Then
ReDim arrTmp(1 To 3)
arrTmp(1) = arrValues(lElement, 1) & ", "
arrTmp(2) = arrValues(lElement, 3)
arrTmp(3) = arrValues(lElement, 2)
DIC.Item(arrValues(lElement, 3)) = arrTmp
Else
arrTmp = DIC.Item(arrValues(lElement, 3))
ReDim Preserve arrTmp(1 To UBound(arrTmp) + 1)
arrTmp(1) = arrTmp(1) & arrValues(lElement, 1) & ", "
arrTmp(UBound(arrTmp)) = arrValues(lElement, 2)
DIC.Item(arrValues(lElement, 3)) = arrTmp
End If
Next

arrValues = DIC.Items

With ThisWorkbook.Worksheets.Add
For RowIndex = 2 To DIC.Count + 1
For ColumnIndex = 1 To UBound(arrValues(RowIndex - 2))
If ColumnIndex = 1 Then
.Cells(RowIndex, ColumnIndex) = Left$(arrValues(RowIndex - 2)(ColumnIndex), Len(arrValues(RowIndex - 2)(ColumnIndex)) - 2)
Else
.Cells(RowIndex, ColumnIndex) = arrValues(RowIndex - 2)(ColumnIndex)
End If
Next
Next
.UsedRange.Columns.AutoFit
End With

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


See attached example...

Mark

[N1ck9141]

Hi Mark,

This is perfect for what i wanted, and looks like it will work great regardless of size of list or number of groups thank you very much for this life saver!.

This is solved

kind regards

[GTO]

You are most welcome and thank you for the kind feedback :)

[snb]

This should suffice:


Sub M_snb()
sn = Sheet1.Cells(1).CurrentRegion
ReDim sp(2)

With CreateObject("scripting.dictionary")
For j = 2 To UBound(sn)
st = sp
If .exists(sn(j, 3)) Then st = .Item(sn(j, 3))
st(0) = st(0) + IIf(st(0) = "", "", ", ") & sn(j, 1)
st(1) = sn(j, 3)
st(2) = st(2) + IIf(st(2) = "", "", ";") & sn(j, 2)
.Item(sn(j, 3)) = st
Next

Sheet1.Cells(1, 10).Resize(.Count, 3) = Application.Index(.items, 0, 0)
End With

Sheet1.Columns(12).TextToColumns , 1, 1, 0, 0, -1, 0, 0, 0
End Sub