copy multiple rows to new single row sequentially in new worksheet

[jetpack]

excel 2016

I have 40+ columns of data in 100s of rows.

At a specified time each day I need to copy each row sequentially to a single row in a new worksheet.

As an example:

DataSheet is the sheet from which data should be copied. NewSheet is the receiving sheet.

Process would be as follows;

copy DataSheet A1:A40 to NewSheet A1 and add 1 blank column at end.
copy DataSheet B1:B40 to NewSheet A42 and add 1 blank column at end.
copy DataSheet C1:C40 to NewSheet A:84 and add 1 blamk column at end.
copy DataSheet D1:D40 to NewSheet A:125 and add 1 blank column at end.
Continue to end of rows.

# of columns and rows may change from day to day, but will always be the same # of each on any particular sheet. NewSheet would be named according to date procedure is ran, ie; 1_23_18 for Jan 23 2018.

Seems like a combination of loops and count(), but beyond my ability to construct anything that works.

Appreciate everyone who takes the time to read this post!

 

[jetpack]

The example I used in the reply was just that, an example.

The data will always be the same # of columns on a particular sheet. If the 1st row contains data from A:AI, all rows in that sheet will contain data from A:AI.

The # of columns may vary from sheet to sheet, but there will never be more than 40 columns, though on some sheets there may be only 20.

The # of rows may vary from sheet to sheet.

The sample data that I have been using to test the macro always begins in A1.

Hope that explains it better?

 

[My Aswer Is This]

This is beyond my knowledgebase.
I will continue to monitor this thread to see what I can learn.

Maybe Rick who asked questions earlier will be able to help you.

 

[Akuini]

The example I used in the reply was just that, an example.

The data will always be the same # of columns on a particular sheet. If the 1st row contains data from A:AI, all rows in that sheet will contain data from A:AI.

The # of columns may vary from sheet to sheet, but there will never be more than 40 columns, though on some sheets there may be only 20.

The # of rows may vary from sheet to sheet.

The sample data that I have been using to test the macro always begins in A1.

Hope that explains it better?

Hi, jetpack
You may try this code.
The code will truncate the pasted data if the result exceeds 16384 column.
What do you want if that happens? Paste the data to the next row?

[B][COLOR=Royalblue]Sub[/COLOR][/B] a1079405b()
[I][COLOR=seagreen]'https://www.mrexcel.com/forum/excel-questions/1079405-copy-multiple-rows-new-single-row-sequentially-new-worksheet.html[/COLOR][/I]
[B][COLOR=Royalblue]Dim[/COLOR][/B] wb1 [B][COLOR=Royalblue]As[/COLOR][/B] Worksheet, wb2 [B][COLOR=Royalblue]As[/COLOR][/B] Worksheet
[B][COLOR=Royalblue]Dim[/COLOR][/B] a [B][COLOR=Royalblue]As[/COLOR][/B] [B][COLOR=Royalblue]Long[/COLOR][/B], b [B][COLOR=Royalblue]As[/COLOR][/B] [B][COLOR=Royalblue]Long[/COLOR][/B], j [B][COLOR=Royalblue]As[/COLOR][/B] [B][COLOR=Royalblue]Long[/COLOR][/B], k [B][COLOR=Royalblue]As[/COLOR][/B] [B][COLOR=Royalblue]Long[/COLOR][/B], i [B][COLOR=Royalblue]As[/COLOR][/B] [B][COLOR=Royalblue]Long[/COLOR][/B]
[B][COLOR=Royalblue]Dim[/COLOR][/B] msg [B][COLOR=Royalblue]As[/COLOR][/B] [B][COLOR=Royalblue]String[/COLOR][/B]
[B][COLOR=Royalblue]Dim[/COLOR][/B] va [B][COLOR=Royalblue]As[/COLOR][/B] [B][COLOR=Royalblue]Variant[/COLOR][/B], vb [B][COLOR=Royalblue]As[/COLOR][/B] [B][COLOR=Royalblue]Variant[/COLOR][/B]

sName = Format([B][COLOR=Royalblue]Date[/COLOR][/B], [COLOR=brown]"mmm-dd-yyyy"[/COLOR]) & Format(Time, [COLOR=brown]" hh mm ss"[/COLOR])
[B][COLOR=Royalblue]If[/COLOR][/B] Evaluate([COLOR=brown]"ISREF('"[/COLOR] & sName & [COLOR=brown]"'!A1)"[/COLOR]) [B][COLOR=Royalblue]Then[/COLOR][/B]
    [B][COLOR=Royalblue]Exit[/COLOR][/B] [B][COLOR=Royalblue]Sub[/COLOR][/B]
[B][COLOR=Royalblue]Else[/COLOR][/B]
    [B][COLOR=Royalblue]Set[/COLOR][/B] wb1 = ActiveSheet
    Sheets.Add(After:=Sheets(Sheets.count)).Name = sName
    [B][COLOR=Royalblue]Set[/COLOR][/B] wb2 = ActiveSheet
[B][COLOR=Royalblue]End[/COLOR][/B] [B][COLOR=Royalblue]If[/COLOR][/B]

wb1.Activate
a = Range([COLOR=brown]"A"[/COLOR] & Rows.count).[B][COLOR=Royalblue]End[/COLOR][/B](xlUp).Row
b = Cells([COLOR=crimson]1[/COLOR], Columns.count).[B][COLOR=Royalblue]End[/COLOR][/B](xlToLeft).Column
va = Range(Cells([COLOR=crimson]1[/COLOR], [COLOR=brown]"A"[/COLOR]), Cells(a, b))

[B][COLOR=Royalblue]ReDim[/COLOR][/B] vb([COLOR=crimson]1[/COLOR] [B][COLOR=Royalblue]To[/COLOR][/B] [COLOR=crimson]1[/COLOR], [COLOR=crimson]1[/COLOR] [B][COLOR=Royalblue]To[/COLOR][/B] [COLOR=crimson]16384[/COLOR])
k = [COLOR=crimson]1[/COLOR]
[B][COLOR=Royalblue]For[/COLOR][/B] i = [COLOR=crimson]1[/COLOR] [B][COLOR=Royalblue]To[/COLOR][/B] UBound(va, [COLOR=crimson]1[/COLOR])
    [B][COLOR=Royalblue]For[/COLOR][/B] j = [COLOR=crimson]1[/COLOR] [B][COLOR=Royalblue]To[/COLOR][/B] UBound(va, [COLOR=crimson]2[/COLOR])
        
        [B][COLOR=Royalblue]If[/COLOR][/B] k > [COLOR=crimson]16384[/COLOR] [B][COLOR=Royalblue]Then[/COLOR][/B] msg = [COLOR=brown]"Truncated at row "[/COLOR] & d & [COLOR=brown]" column "[/COLOR] & e: [B][COLOR=Royalblue]GoTo[/COLOR][/B] skip:
        d = i: e = j
        vb([COLOR=crimson]1[/COLOR], k) = va(i, j)
        k = k + [COLOR=crimson]1[/COLOR]
        
    [B][COLOR=Royalblue]Next[/COLOR][/B]
    k = k + [COLOR=crimson]1[/COLOR]
[B][COLOR=Royalblue]Next[/COLOR][/B]

skip:
[B][COLOR=Royalblue]If[/COLOR][/B] k > [COLOR=crimson]16384[/COLOR] [B][COLOR=Royalblue]Then[/COLOR][/B] k = [COLOR=crimson]16384[/COLOR]
wb2.Cells([COLOR=crimson]2[/COLOR], [COLOR=crimson]1[/COLOR]).Resize(, k) = vb
[B][COLOR=Royalblue]If[/COLOR][/B] Len(msg) > [COLOR=crimson]0[/COLOR] [B][COLOR=Royalblue]Then[/COLOR][/B] MsgBox msg

[B][COLOR=Royalblue]End[/COLOR][/B] [B][COLOR=Royalblue]Sub[/COLOR][/B]

 

[jetpack]

Thank you very much for all the time and effort. The code is very close to what I need.
Maybe someone can add the missing parts.

 

[Akuini]

Thank you very much for all the time and effort. The code is very close to what I need.
Maybe someone can add the missing parts.

What are the missing part?

 

[jetpack]

Akuini,

I'm sorry, that reply was meant for My Answer is This.

I am now testing your code and it appears to be exactly what I need, even copying the data to row 2. The trucation is a nice touch, but to answer your question, the data will never approach the column limit of 16384.

Can the macro be coded to run Sunday through Friday at a user specified time?

Thank you ever so much for your help. It is much appreciated.

 

[jetpack]

My Answer is This,

Thank you very much for all the time and effort. The code is very close to what I need.
Maybe someone can add the missing parts.

Update; Akuini has very graciously supplied code that appears to meet my need.

Thank you again for your help.

 

[Akuini]

My Answer is This,

Thank you very much for all the time and effort. The code is very close to what I need.
Maybe someone can add the missing parts.

Update; Akuini has very graciously supplied code that appears to meet my need.

Thank you again for your help.

Ok, glad it works.

 

[My Aswer Is This]

I had to go to bed but here is how I would have done it.

Sub Copy_My_Data()
'Modified  12/2/2018  8:47:02 AM  EST
Application.ScreenUpdating = False
On Error GoTo M
Dim i As Long
Dim ans As String
Dim Lastrow As Long
Dim Lastcc As Long
Dim LastColumn As Long
Sheets.Add(After:=Sheets(Sheets.Count)).Name = Format(Date, "mmm dd yyyy")
ans = ActiveSheet.Name
Sheets(1).Activate
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    
For i = 1 To Lastrow
    Sheets(1).Cells(i, 1).Resize(, LastColumn).Copy
        Lastcc = Sheets(ans).Cells(2, Columns.Count).End(xlToLeft).Column + 2
            If i < 2 Then Lastcc = 1
        Sheets(ans).Cells(2, Lastcc).PasteSpecial xlPasteValues
Next
   
Application.CutCopyMode = False
Application.ScreenUpdating = True
Exit Sub
M:
MsgBox "The sheet named  " & Date & " Already exist. I have stopped the script"

End Sub

 

[jetpack]

My Answer is This.

Have tested the macro and it copies everything just the way I need and even puts it in row 2.

The only problem is once again the error message comes up that the sheet already exists and the ok has to be clicked for it to actually create the new sheet.

The only thing in the workbook is the sheet1 with the sample data before the macro is ran.

Any input will be much appreciated, and thank you again for your help.