Creating a macro to move info in a column to rows

[cmaronde]

Hello, I am trying to figure out how to move data from columns to a row. The following data comes like the example below, with Data1 being the first grouping, data2 is the second grouping and this needs to keep repeating until there is no more data (the only info I need is the data in column A, the rest can be discarded):

Data1-1
	Data1-2
Data1-3
	Data1-4
Data1-5
				Data1-6	Data1-7
Data2-1
	Data2-2
Data2-3
	Data2-4
Data2-5
				Data2-6	Data2-7

I want it to come out in 1 row:

Data1-1	Data1-3	Data1-5
Data2-1	Data2-3	Data2-5

Thanks for any help!

 

[lrobbo314]

You can do this with Power Query.

Book1
	A	B	C	D	E	F	G
2	Data1-1
3		Data1-2
4	Data1-3
5		Data1-4
6	Data1-5
7					Data1-6	Data1-7
8	Data2-1
9		Data2-2
10	Data2-3
11		Data2-4
12	Data2-5
13					Data2-6	Data2-7
14
15
16
17	Custom.1.1	Custom.1.2	Custom.1.3	Custom.1.4	Custom.1.5	Custom.1.6	Custom.1.7
18	Data1-1	Data1-3	Data1-5	Data1-2	Data1-4	Data1-6	Data1-7
19	Data2-1	Data2-3	Data2-5	Data2-2	Data2-4	Data2-6	Data2-7
Sheet2

let
    Source = List.RemoveNulls(List.Combine(Table.ToColumns(Excel.CurrentWorkbook(){[Name="Table1"]}[Content]))),
    ToTable = Table.FromList(Source, Splitter.SplitByNothing(), null, null, ExtraValues.Error),
    GroupKey = Table.AddColumn(ToTable, "Custom", each Text.Middle([Column1],0,5)),
    Group = Table.Group(GroupKey, {"Custom"}, {{"Count", each _, type table}}),
    GetList = Table.AddColumn(Group, "Custom.1", each Table.Column([Count],"Column1")),
    Extract = Table.TransformColumns(GetList, {"Custom.1", each Text.Combine(List.Transform(_, Text.From), ","), type text}),
    Split = Table.SplitColumn(Extract, "Custom.1", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), {"Custom.1.1", "Custom.1.2", "Custom.1.3", "Custom.1.4", "Custom.1.5", "Custom.1.6", "Custom.1.7"}),
    RC = Table.RemoveColumns(Split,{"Custom", "Count"})
in
    RC

 

[cmaronde]

Thanks for the reply lrobbo314 but unfortunately, I have Excel 2013, which does not have power query and as this is a work laptop, I cannot download it. Any other thoughts?

 

[lrobbo314]

Give this a shot.

Sub FLATTEN()
Dim r As Range:         Set r = Range("A1:G12")
Dim AR() As Variant:    AR = r.Value
Dim SD As Object:       Set SD = CreateObject("Scripting.Dictionary")

Dim RO As Integer, CO As Integer
Dim x As Variant, y As Variant
Dim ID As String

For i = 1 To UBound(AR)
    For j = 1 To UBound(AR, 2)
        If Not IsEmpty(AR(i, j)) Then
            ID = Left(AR(i, j), 5)
            SD(ID) = SD(ID) + 1
        End If
    Next j
Next i

r.ClearContents
x = SD.items
y = SD.keys

For RO = 1 To UBound(y) + 1
    For CO = 1 To x(RO - 1)
        Cells(RO, CO) = y(RO - 1) & "-" & CO
    Next CO
Next RO

End Sub

 

[cmaronde]

When I ran it, it only worked for a but then stopped (row 13 is the start of the 3rd name) but also shortened the names and added -1.

 

[lrobbo314]

If you look at the code you can see where it is getting the left 5 characters of each cell. That was based off of your sample data in your OP, e.g. 'Data-1', 'Data-2', etc. Looking at you last post, that data is way different that the sample.

Can you post your actual data and how you want it to look after the code is run.

 

[cmaronde]

AH, sorry about that. Here is sample info that i have but the data can go into the thousands:

 

[lrobbo314]

That's a fine sample size. And how do you want it to look after the code is run? Just a sample of the first few should be ok.

 

[cmaronde]

So, whichever is easier to program:

or just names and email addresses as that's truly all I need:

I really appreciate the help on this!