Covert cells with multiple data to rows

[maxnimrod]

We use a SharePoint library for end users to submit requests for changes. Because they can submit multiple lines of changes, this produces an output file like the one below.

I don't mind copying the data and pasting it to another sheet. However that can be quite time consuming when there are dozens of requests. Plus, other people may process these so I need an easier solution.

	A	B	C	D	E	F	G	H	I
Row1	Record #	Date	Requestor	R#	U#	Data1	Data2	Data3	# of Requests
Row2	101	4-Jul	John	2001	ABC	Red	Green	Yes	5
				2002	DEF	Brown	Orange	No
				2003	GHI	Purple	Blue	No
				2004	JKL	Yellow	Pink	Yes
				2005	MNO	Black	White	No
Row3	104	7-Jul	Mike	3011	PFY	Red	Green	Yes	5
				3012	GHK	Brown	Orange	No
				3013	DCC	Purple	Blue	No
				3014	MMZ	Yellow	Pink	Yes
				3015	XGF	Black	White	No
Row 4	105	9-Jul	Jack	2009	DCF	Green	Black	No	1

<tbody>
</tbody><colgroup><col><col><col><col><col span="5"><col></colgroup>

For example, On July 4th, John submitted a request that contained 5 changes. His request first request # is 2001 and he needs artifact ABC changed from Red to Green. And yes or no for manager approval.
Column I contains the number of requests Each user submitted, so that may be helpful. You will notice that the request in row 4 only contained 1 request. So those would be ok as they are.

I need an easy way to put each row of data that a user submits into it's own row. I don't care so much if columns A, B and C don't get copied down. It is easy enough to drag them after the fact.

Any advice would be greatly appreciated.
Thank

 

[frank_AL]

maxnimrod,

This code copies the data from Sheet1 to Sheet2. For now, this does not copy the data to something like a master Workbook but that would be easy enough to add if needed.
If this isn't exactly what you need provide details of what needs changing and I will work to incorporate that into an updated code module.

Option Explicit
Sub CopyData()
Dim i As Long
Dim x As Long
Dim cflr As Long
Dim ctlr As Long
Dim lastrec As Long
Dim CFws As Worksheet
Dim CTws As Worksheet


Set CFws = Sheets("Sheet1")  '  Copy From Worksheet
Set CTws = Sheets("Sheet2")  '  Copy To Worksheet


cflr = CFws.Cells(Rows.Count, "A").End(xlUp).Row  '  Copy From WorkSheet Last Row


For i = 2 To cflr
ctlr = CTws.Cells(Rows.Count, "A").End(xlUp).Row + 1  '  Copy To WorkSheet Last Row
lastrec = CFws.Cells(i, 9).Value
    
    For x = i To (i + lastrec - 1)
        CFws.Cells(i, 1).Copy Destination:=CTws.Cells(ctlr, 1)
        CFws.Cells(i, 2).Copy Destination:=CTws.Cells(ctlr, 2)
        CFws.Cells(i, 3).Copy Destination:=CTws.Cells(ctlr, 3)
        CFws.Cells(x, 4).Copy Destination:=CTws.Cells(ctlr, 4)
        CFws.Cells(x, 5).Copy Destination:=CTws.Cells(ctlr, 5)
        CFws.Cells(x, 6).Copy Destination:=CTws.Cells(ctlr, 6)
        CFws.Cells(x, 7).Copy Destination:=CTws.Cells(ctlr, 7)
        CFws.Cells(x, 8).Copy Destination:=CTws.Cells(ctlr, 8)
        ctlr = ctlr + 1
    Next x
Next i


End Sub

 

[maxnimrod]

Hi,

Thank you for your reply. I can see this working, however, the results are mostly the same as Sheet1. When it does create a new row, it doesn't fill in anything after column C. I think your idea Is spot on, but I think the issue is the data itself. For columns D-H. If I copy one row of my data to a plain text editor this is what I see. Column A, B and C are clean. Only the data we see. However, starting with column D, each group of data begins and end with a quote " there is nothing between each value. I don't know if that fact is helpful or detrimental.

Thank you again for your help))

 

[frank_AL]

That's helpful information but can you post a screenshot of a set of rows for an individual person? Follow the Forum Use Guidelines for instructions on how to do this.
Feel free to edit any personally identifiable data, I just need to know the actual structure of the data.

I'm hoping the data is in specific text positions so that it will be easy to parse.

 

[maxnimrod]

Thank you again for your reply. I can't use the add ins at work. I will try and get this sheet home and try that tonight.

In the meantime, I can tell you that all the data is stacked in the cells and it is aligned to the bottom of the cells. Not sure if that is helpful or not. I will get you the screenshot as soon as I can.

Thank you!!

 

[maxnimrod]

Here we go)) There are 4 rows of data. Let me know if there is anything else you want to see. The data is actually requests for UNC path changes. I scrubbed the ID's and paths. Thank you ))

Book1
	A	B	C	D	E	F	G	H	I
1	ID	Processing Date	Submitted By	Request Number	ID	NEW Path	OLD Path	Group	Count
2	1166	8/16/2017	John	3982305 3990521 3990601 3990605 3990607 3990608 3992829 3992835 3992850 3992874 3992878	ID001 ID002 ID003 ID004 ID005 ID006 ID007 ID008 ID009 ID010 ID011	\\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user	\\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user	true true true true true true true true true true true	11
3	1167	8/16/2017	Mike	3942554	ID106	\\server\path\user	\\server\path\user	true	1
4	1168	8/16/2017	Jack	4002114 4002113 4002062 4002053 4002051 4000028 3999940	ID11001 ID11002 ID11003 ID11004 ID11005 ID11006 ID11007	\\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user	\\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user	true true true true true true true	7
5	1169	8/16/2017	Cindy	3982425 3989379 3989984 3992887 3992893 3995697 3995786 3999639	ID110013 ID110023 ID110033 ID110043 ID110053 ID110063 ID110073 ID110098	\\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user	\\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user \\server\path\user	true true true true true true true true	8
Sheet1

 

[frank_AL]

Okay, sorry to be so long getting back to you. Been dealing with personal issues on my end!

Give this code a try. The assumption here is that the data in Columns D-H is separated with a space " ". It is possible it might be separate with a line feed and if so it will take a minor modification the lines of code that Split the data into the arrays so let me know if this fails on your actual data.

Option Explicit
Sub CopyData()
Dim i As Long
Dim x As Long
Dim cflr As Long
Dim ctlr As Long
Dim cnt As Long
Dim CFws As Worksheet
Dim CTws As Worksheet
Dim Req As String
Dim ID As String
Dim NP As String
Dim OP As String
Dim Grp As String




Set CFws = Sheets("Sheet4")  '  Copy From Worksheet
Set CTws = Sheets("Sheet5")  '  Copy To Worksheet


cflr = CFws.Cells(Rows.Count, "A").End(xlUp).Row  '  Copy From WorkSheet Last Row


For i = 2 To cflr
    ctlr = CTws.Cells(Rows.Count, "A").End(xlUp).Row + 1  '  Copy To WorkSheet Last Row
    cnt = CFws.Cells(i, 9).Value
    ReDim ReqArray(1 To cnt) As String
    ReDim IDArray(1 To cnt) As String
    ReDim NPArray(1 To cnt) As String
    ReDim OPArray(1 To cnt) As String
    ReDim GrpArray(1 To cnt) As String
    Req = CFws.Cells(i, 4)
    ID = CFws.Cells(i, 5)
    NP = CFws.Cells(i, 6)
    OP = CFws.Cells(i, 7)
    Grp = CFws.Cells(i, 8)
    ReqArray = Split(Req)
    IDArray = Split(ID)
    NPArray = Split(NP)
    OPArray = Split(OP)
    GrpArray = Split(Grp)
    
    For x = 1 To (cnt)
        CFws.Cells(i, 1).Copy Destination:=CTws.Cells(ctlr, 1)
        CFws.Cells(i, 2).Copy Destination:=CTws.Cells(ctlr, 2)
        CFws.Cells(i, 3).Copy Destination:=CTws.Cells(ctlr, 3)
        CTws.Cells(ctlr, 4) = ReqArray(x - 1)
        CTws.Cells(ctlr, 5) = IDArray(x - 1)
        CTws.Cells(ctlr, 6) = NPArray(x - 1)
        CTws.Cells(ctlr, 7) = OPArray(x - 1)
        CTws.Cells(ctlr, 8) = GrpArray(x - 1)
        ctlr = ctlr + 1
    Next x
Next i


End Sub

 

[Fluff]

Hia
Here's another option for you.
This converts the data on the same sheet, rather than copying to a new sheet.
Like frank_AL' code this assumes that the data in cols D to G is split on a space, but can be changed

Sub SplitRws()
' maxnimrod (zz2)

    Dim UsdRws As Long
    Dim Rws As Long
    Dim Cnt As Long
    Dim Cols As Long

Application.ScreenUpdating = False

    UsdRws = Range("A" & Rows.Count).End(xlUp).Row
    
    For Rws = UsdRws To 2 Step -1
        Cnt = Range("I" & Rws).Value
        If Cnt > 1 Then
            Rows(Rws + 1).Resize(Cnt - 1).Insert
            Range("A" & Rws & ":C" & Rws).Resize(Cnt).FillDown
            For Cols = 4 To 8
                Cells(Rws, Cols).Resize(Cnt).Value = Application.Transpose(Split(Cells(Rws, Cols).Value))
            Next Cols
        End If
    Next Rws

End Sub

 

[frank_AL]

Hia
Here's another option for you.
This converts the data on the same sheet, rather than copying to a new sheet.
Like frank_AL' code this assumes that the data in cols D to G is split on a space, but can be changed

Sub SplitRws()
' maxnimrod (zz2)

    Dim UsdRws As Long
    Dim Rws As Long
    Dim Cnt As Long
    Dim Cols As Long

Application.ScreenUpdating = False

    UsdRws = Range("A" & Rows.Count).End(xlUp).Row
    
    For Rws = UsdRws To 2 Step -1
        Cnt = Range("I" & Rws).Value
        If Cnt > 1 Then
            Rows(Rws + 1).Resize(Cnt - 1).Insert
            Range("A" & Rws & ":C" & Rws).Resize(Cnt).FillDown
            For Cols = 4 To 8
                Cells(Rws, Cols).Resize(Cnt).Value = Application.Transpose(Split(Cells(Rws, Cols).Value))
            Next Cols
        End If
    Next Rws

End Sub

Fluff, your code is the very reason I participate on this Forum. Your code is certainly more efficient and gets the job done!

Frank_al

 

[Fluff]

Thanks for that Frank_al
I'm here for the same reasons, a few months a probably couldn't have done this.