Group and ungroup

[Danny]

Hi all
I have a spreadsheet which has a list of data that was previously
grouped via the group and ungroup excel function.
I have removed this and want to concatenate data within the old
groups. As an example the data is like so.....

A
B
C
D
E
F
G
H
I
J
K

What i want to achieve is to group in cell A1 - A,B,C and then in A2 -
D,E,F and then in A3 - G,H,I,J,K

My code so far is below which allows me to group the first level but i
need to to take into account the second example of G,H,I,J,K which
covers more than two or three concatenations.

Can anyone help
Thanks very much


=====================
Dim fCell As Excel.Range
Dim sCell As Excel.Range

i = 0
r = 0

With ThisWorkbook.Sheets(1).Cells
Set fCell = .Range("A6")
Set sCell = .Range("C6")

With ThisWorkbook.Sheets(1).UsedRange
lLastRow = .Row + .Rows.Count - 1
End With

Do Until i >= lLastRow
If iPrev = fCell.Offset(i, 0).Value Then
If sCell.Offset(i + 1, 0).Value <> "" Then
Do While fCell.Offset(i, 0).Value
= ""
If iDesc = sCell.Offset(i,
0).Value Then
If sCell.Offset(r,
2).Value <> "" Then
Do Until
sCell.Offset(r, 2).Value = ""
myval =
sCell.Offset(r, 2).Value
r = r + 1
i = i + 1
Loop
End If
Else

End If
iDesc = sCell.Offset(i, 0).Value
i = i + 1
r = r + 1
Loop
End If

Else

End If
iPrev = fCell.Offset(i, 0).Value
r = r + 1
Loop

End With

End Sub
============================

 

[John Bundy]

addmittedly not the prettiest, but its been a long day, try this out

Sub main()
Dim myRow As Long
Dim myCol As Long
Dim myString As String
Dim startRow As Long
myCol = 1
myRow = 1
startRow = 1
Do Until Cells(myRow, 1) = ""
Do Until Cells(myRow, myCol) = ""
myString = myString & Cells(myRow, myCol)
myRow = myRow + 1
myCol = myCol + 1
Loop
myCol = 1

Cells(startRow, 1) = myString
startRow = myRow
myString = ""
If Cells(myRow, 1) = "" Then Exit Sub
Loop
End Sub

 

[Danny]

addmittedly not the prettiest, but its been a long day, try this out

Sub main()
Dim myRow As Long
Dim myCol As Long
Dim myString As String
Dim startRow As Long
myCol = 1
myRow = 1
startRow = 1
Do Until Cells(myRow, 1) = ""
Do Until Cells(myRow, myCol) = ""
myString = myString & Cells(myRow, myCol)
myRow = myRow + 1
myCol = myCol + 1
Loop
myCol = 1

Cells(startRow, 1) = myString
startRow = myRow
myString = ""
If Cells(myRow, 1) = "" Then Exit Sub
Loop
End Sub

--
-John
Please rate when your question is answered to help us and others know what
is helpful.















- Show quoted text -

----------
Hi John
Thanks very much for that, i have tweaked it slightly and fitted it in
with what i had done previously but one other thing is that i have a
more complex example of the group and outline.

A
B
C
D
E
F
G
H
I
J
K
L
M

Therefore i would need to concatenate the A,B,C and A,B,D etc and then
A,G,H etc
How would it be possible to always keep the A whilst moving down and
looping to the next layers.
Thanks again in advance