New Line Data

[Craddox]

Hi, I am struggling.... So what's new.

I have a worksheet in excel that has multiple rows and mutliple columns populated through VBA as text and numbers. Part of this is that from column S through to column XFD there could be a number that needs moving to the next line on the same worksheet. Once the number has been moved, the rest of the row (columns A through R) need to be copied to the same "new" row as the number. The code then needs to move onto the next column and do the same then once the row is completely checked it needs to move onto the next row and do the same again.

Some rows don't have any numbers in S:XFD and others could have numbers in every column.

Does anyone have any clues on how to do this and is this even possible?

 

[Jeffrey Mahoney]

Yes, that is easy. Can you post that using XL2BB?

 

[Craddox]

Unfortunately, my system security won't allow me to open the xl2bb file so I can't send this in this format.

 

[MARK858]

my system security won't allow me to open the xl2bb

Are you sure it isn't just the windows system putting it's normal block on files containing macro's that are downloaded

It is covered in the link in the instructions

or put the file in a Trusted location

 

[Craddox]

Are you sure it isn't just the windows system putting it's normal block on files containing macro's that are downloaded

It is covered in the link in the instructions

View attachment 111644



or put the file in a Trusted location

Got it - you were correct. I missed that instruction...

 

[Craddox]

Example Sheet.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ
1	What I have
2	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ
3	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	1			2	4	5	5	1
4	2	1	3	5	2	1	1	4	1	2	3	4	2	1	1	2	5	5	4
5	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	2				4	4	1	1	5			4	1	2	3	5	4	2
6	4	3	3	3	5	5	4	1	4	5	1	1	1	4	4	5	3	3	1
7	5	4	2	3	5	4	2	5	1	5	5	2	5	4	3	5	5	4	1
8
9	What I want (after running code)
10	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ
11	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	1
12	2	1	3	5	2	1	1	4	1	2	3	4	2	1	1	2	5	5	4
13	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	2
14	4	3	3	3	5	5	4	1	4	5	1	1	1	4	4	5	3	3	1
15	5	4	2	3	5	4	2	5	1	5	5	2	5	4	3	5	5	4	1
16	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	2
17	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	4
18	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	5
19	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	5
20	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	1
21	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	4
22	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	4
23	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	1
24	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	1
25	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	5
26	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	4
27	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	1
28	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	2
29	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	3
30	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	5
31	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	4
32	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	2
Sheet1

 

[Craddox]

As this is the first time using XL2BB to upload a mini sheet - does this work for you? Thanks

 

[MARK858]

The XL2BB is fine, the Mini sheet is the correct default option to use for posting.
I'll leave it for @Jeffrey Mahoney to look at as he requested it.

 

[Jeffrey Mahoney]

Ok here's my first stab at it. I assumed headers to start on row one for each sheet. Also assumed you wanted the data copied to another sheet. Also assumed you didn't want to erase the data in the out range on sheet2. Assumed you didn't need coloring from the cells

BookAAA 20240520.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ
1	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ
2	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	1			2	4	5	5	1
3	2	1	3	5	2	1	1	4	1	2	3	4	2	1	1	2	5	5	4
4	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	2				4	4	1	1	5			4	1	2	3	5	4	2
5	4	3	3	3	5	5	4	1	4	5	1	1	1	4	4	5	3	3	1
6	5	4	2	3	5	4	2	5	1	5	5	2	5	4	3	5	5	4	1
Sheet1

BookAAA 20240520.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
2	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	1
3	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	2
4	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	4
5	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	5
6	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	5
7	1	3	4	5	2	5	3	2	4	4	4	4	5	3	5	4	3	5	1
8	2	1	3	5	2	1	1	4	1	2	3	4	2	1	1	2	5	5	4
9	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	2
10	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	4
11	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	4
12	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	1
13	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	1
14	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	5
15	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	4
16	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	1
17	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	2
18	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	3
19	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	5
20	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	4
21	3	4	1	1	3	4	1	5	5	2	1	5	3	2	4	3	1	3	2
22	4	3	3	3	5	5	4	1	4	5	1	1	1	4	4	5	3	3	1
23	5	4	2	3	5	4	2	5	1	5	5	2	5	4	3	5	5	4	1
Sheet2

Sub CreateNewLines()
  Dim Cel As Range
  Dim CC As Range
  Dim Rng As Range
  Dim aSht As Worksheet
  Dim NewSht As Worksheet
  Dim ColTAJ As Range
  Dim ColAS As Range
  Dim OutS As Range
  Dim OutCel As Range
  Dim OutRng As Range
  
  
  Set aSht = ActiveSheet
  Set ColAS = aSht.Range("A:S")
  Set ColTAJ = aSht.Range("T:AJ")
  Set NewSht = Sheets("Sheet2")   'Copy the data to this sheet
  Set OutS = NewSht.Range("S1")   'Top of table where data needs to be copied
  
  Set Cel = Range("A2")           'Starting row of data to be copied
  With aSht
    Set Rng = Range(Cel, .Cells(.Cells.Rows.Count, 1).End(xlUp))  'Values in column A
  End With
  
  For Each Cel In Rng
    Set OutCel = NewSht.Cells(NewSht.Rows.Count, OutS.Column).End(xlUp).Offset(1, 0)  'Next blank row
    Set OutRng = Intersect(NewSht.Range("A:S"), OutCel.EntireRow)                     'Columns A - S
    OutRng.Value = Intersect(Cel.EntireRow, ColAS).Value
    For Each CC In Intersect(ColTAJ, Cel.EntireRow)
      If CC.Value <> "" Then
        Set OutCel = NewSht.Cells(NewSht.Rows.Count, OutS.Column).End(xlUp).Offset(1, 0)  'Next blank row
        Set OutRng = Intersect(NewSht.Range("A:S"), OutCel.EntireRow)                     'Columns A - S
        OutRng.Value = Intersect(Cel.EntireRow, ColAS).Value
        OutCel.Value = CC.Value                                                           'Copy new value
      End If
    Next CC
  Next Cel
  
End Sub

 

[Craddox]

Hi Jeffrey,

Thank you for the code although i am a little lost with some of it. I've had to adapt it a little as the ranges in the "actual" sheet is different to those in the mock up. When I've run the code there appear to be 2 issues:

1. It takes forever to run and keeps flashing up that it's calculating the threads.
2. It only appears to copy the header row and doesn't copy anything else.

This could be purely due to the adaptations I made but I can't see where I've gone wrong.

Any help would be appreciated.

Thanks

The adapted code is shown below:

Sub CreateNewLines()
'
Dim Cel As Range
Dim CC As Range
Dim Rng As Range
Dim aSht As Worksheet
Dim NewSht As Worksheet
Dim ColTAJ As Range
Dim ColAS As Range
Dim OutS As Range
Dim OutCel As Range
Dim OutRng As Range

Set aSht = ActiveSheet
Set ColAS = aSht.Range("B:R")
Set ColTAJ = aSht.Range("S:AJ")
Set NewSht = Sheets("Income") 'Copy the data to this sheet
Set OutS = NewSht.Range("B2") 'Top of table where data needs to be copied

Set Cel = Range("A2") 'Starting row of data to be copied
With aSht
Set Rng = Range(Cel, .Cells(.Cells.Rows.Count, 1).End(xlUp)) 'Values in column A
End With

For Each Cel In Rng
Set OutCel = NewSht.Cells(NewSht.Rows.Count, OutS.Column).End(xlUp).Offset(1, 0) 'Next blank row
Set OutRng = Intersect(NewSht.Range("B:R"), OutCel.EntireRow) 'Columns B - R
OutRng.Value = Intersect(Cel.EntireRow, ColAS).Value
For Each CC In Intersect(ColTAJ, Cel.EntireRow)
If CC.Value <> "" Then
Set OutCel = NewSht.Cells(NewSht.Rows.Count, OutS.Column).End(xlUp).Offset(1, 0) 'Next blank row
Set OutRng = Intersect(NewSht.Range("B:R"), OutCel.EntireRow) 'Columns B - R
OutRng.Value = Intersect(Cel.EntireRow, ColAS).Value
OutCel.Value = CC.Value 'Copy new value
End If
Next CC
Next Cel
'
End Sub