Multiple (Specific) Columns to be stacked into another Column within the same WorkSheet (VBA Code)

[Tyjyt]

Hello, I came across an issue whilst stacking multiple (specific) columns in excel. I have 5 columns that needs to be stacked up to last non empty cell. The data changes in every column occasionally, so range of each column might be different. There I do need to include Range.End(xlUp) as well... Looking at "Stack multiple columns VBA code", I was able to gain some clarity, however, I'm met with another obstacle.

Issue: While the code that I referenced was helpful, and successful in transferring across data (names), it isn't the same for cells that contain formulas... I'd like to seek for help to the data that I'm stacking which contains formulas, and it's presented in a % format. Is there any way to copy, and paste the values (e.g 10%, 14%) into another column while excluding the formulas? I think it might be something along the lines of PasteSpecial Paste:=xlPasteValuesAndNumberFormats, but I cant seem to get the code right

Sub Test()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Dim Lastrowa As Long
For i = 1 To 5
Lastrow = Cells(Rows.Count, Choose(i, "C", "G", "K", "O", "R")).End(xlUp).Row + 1
If i = 1 Then
Lastrowa = 2
Else
Lastrowa = Cells(Rows.Count, "V").End(xlUp).Row 'mod
End If
Range(Cells(2, Choose(i, "C", "G", "K", "O", "R")), Cells(Lastrow, Choose(i, "C", "G", "K", "O", "R"))).Copy Cells(Lastrowa + 1, "V")
Next
Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

I see your code here that is not working.
Would you please give me specific details about:

1. What is the name of the sheet where you want these columns stacked.
2. What are the names of the sheets where these columns are you want to copy the columns from
3. And what columns are we copying from.
5. Give details like column B or Column G
Do not say column People and column States

 

[kevin9999]

It looks to me like you're trying to copy the values in columns C, G, K, O, and R to column V? If that's the case, try the following:

Option Explicit
Sub Tyiyt()
    Application.ScreenUpdating = 0
    Dim Ws As Worksheet
    Set Ws = Worksheets("Sheet1")   '<<< change to actual sheet name
    Dim LRowSrc As Long, LRowDest As Long, Col
    
    For Each Col In Array("C", "G", "K", "O", "R")
        LRowSrc = Ws.Cells(Rows.Count, Col).End(3).Row
        LRowDest = Ws.Cells(Rows.Count, "V").End(3).Row + 1
        Ws.Range(Cells(2, Col), Ws.Cells(LRowSrc, Col)).Copy
        Ws.Cells(LRowDest, "V").PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = 0
    Next Col
    
    Application.ScreenUpdating = 1
End Sub

 

[Tyjyt]

I see your code here that is not working.
Would you please give me specific details about:

1. What is the name of the sheet where you want these columns stacked.
2. What are the names of the sheets where these columns are you want to copy the columns from
3. And what columns are we copying from.
5. Give details like column B or Column G
Do not say column People and column States

Hi My Aswer Is This, thanks for helping me out with my query! At the moment, I'm working on the same sheet, titled "Working File" where Columns A to S are being filled with data, and I'm planning to use Column U (Stacked Names) and V (Stacked Percentages).

Columns "A", "E", "I", "M", "Q" are filled with names, and Columns "C", "G", "K", "O", "S" are filled with percentages (their amount of contribution)

The other columns that aren't mentioned are filled with data that produces the percentages in Columns "C", "G", "K", "O", "S". Attached is an image of what I'm roughly doing, and the desired outcome would be seen in Column V and U. I was also thinking if it's possible to combine names that are exactly same, with their percentages added together...

 

[kevin9999]

Option Explicit
Sub Tyiyt_2()
    Application.ScreenUpdating = 0
    Dim Ws As Worksheet
    Set Ws = Worksheets("Sheet1")   '<<< change to actual sheet name
    Dim LRowSrc As Long, LRowDest As Long, Col
    
    For Each Col In Array("C", "G", "K", "O", "S")
        LRowSrc = Ws.Cells(Rows.Count, Col).End(3).Row
        LRowDest = Ws.Cells(Rows.Count, "V").End(3).Row + 1
        Ws.Range(Cells(3, Col), Ws.Cells(LRowSrc, Col)).Copy
        Ws.Cells(LRowDest, "V").PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = 0
        Ws.Range(Cells(3, Col), Ws.Cells(LRowSrc, Col)).Offset(, -2).Copy Ws.Cells(LRowDest, "U")
    Next Col
    
    Application.ScreenUpdating = 1
End Sub

 

[Tyjyt]

Option Explicit
Sub Tyiyt_2()
    Application.ScreenUpdating = 0
    Dim Ws As Worksheet
    Set Ws = Worksheets("Sheet1")   '<<< change to actual sheet name
    Dim LRowSrc As Long, LRowDest As Long, Col
   
    For Each Col In Array("C", "G", "K", "O", "S")
        LRowSrc = Ws.Cells(Rows.Count, Col).End(3).Row
        LRowDest = Ws.Cells(Rows.Count, "V").End(3).Row + 1
        Ws.Range(Cells(3, Col), Ws.Cells(LRowSrc, Col)).Copy
        Ws.Cells(LRowDest, "V").PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = 0
        Ws.Range(Cells(3, Col), Ws.Cells(LRowSrc, Col)).Offset(, -2).Copy Ws.Cells(LRowDest, "U")
    Next Col
   
    Application.ScreenUpdating = 1
End Sub

Hi Kelvin, thank you for responding to my query, I am really appreciative! I'm sorry, I overlooked including some information, and have attached an updated file here. Would you be able to help write the full code based on this? What you have shared here with me, is the 2nd part, which is the stacking of percentages, but I'd need help to stack the names as well!

Also, would it be possible to combine names that are exactly same, with their percentages added together? It's some sort of SUM/UNIQUE function, I think ... Thank you so much for helping me out with this!

 

[kevin9999]

Option Explicit
Sub Tyiyt_3()
    Application.ScreenUpdating = 0
    Dim Ws As Worksheet
    Set Ws = Worksheets("Sheet1")   '<<< change to actual sheet name
    Dim LRowSrc As Long, LRowDest As Long, Col
    
    For Each Col In Array("C", "G", "K", "O", "S")
        LRowSrc = Ws.Cells(Rows.Count, Col).End(3).Row
        LRowDest = Ws.Cells(Rows.Count, "V").End(3).Row + 1
        Ws.Range(Cells(3, Col), Ws.Cells(LRowSrc, Col)).Copy
        Ws.Cells(LRowDest, "V").PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = 0
        Ws.Range(Cells(3, Col), Ws.Cells(LRowSrc, Col)).Offset(, -2).Copy Ws.Cells(LRowDest, "U")
    Next Col
    
    Dim Ar, i As Long, n As Long
    Ar = Ws.Range("U1").CurrentRegion
    
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(Ar, 1)
            .Item(Ar(i, 1)) = .Item(Ar(i, 1)) + Ar(i, 2)
        Next i
        Ar = Array(.keys, .items)
        n = .Count
    End With
    Ws.Range("U1").CurrentRegion.ClearContents
    Ws.Range("U1").Resize(n, 2).Value = Application.Transpose(Ar)
    
    Application.ScreenUpdating = 1
End Sub

 

[My Aswer Is This]

Tyjyt: Glad to see Kevin is giving you some help. The ultimate goal here is to get you the help you need. I will continue to watch.

 

[Tyjyt]

Option Explicit
Sub Tyiyt_3()
    Application.ScreenUpdating = 0
    Dim Ws As Worksheet
    Set Ws = Worksheets("Sheet1")   '<<< change to actual sheet name
    Dim LRowSrc As Long, LRowDest As Long, Col
  
    For Each Col In Array("C", "G", "K", "O", "S")
        LRowSrc = Ws.Cells(Rows.Count, Col).End(3).Row
        LRowDest = Ws.Cells(Rows.Count, "V").End(3).Row + 1
        Ws.Range(Cells(3, Col), Ws.Cells(LRowSrc, Col)).Copy
        Ws.Cells(LRowDest, "V").PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = 0
        Ws.Range(Cells(3, Col), Ws.Cells(LRowSrc, Col)).Offset(, -2).Copy Ws.Cells(LRowDest, "U")
    Next Col
  
    Dim Ar, i As Long, n As Long
    Ar = Ws.Range("U1").CurrentRegion
  
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(Ar, 1)
            .Item(Ar(i, 1)) = .Item(Ar(i, 1)) + Ar(i, 2)
        Next i
        Ar = Array(.keys, .items)
        n = .Count
    End With
    Ws.Range("U1").CurrentRegion.ClearContents
    Ws.Range("U1").Resize(n, 2).Value = Application.Transpose(Ar)
  
    Application.ScreenUpdating = 1
End Sub

Thank you so much, Kelvin! Could you also help me out with the code to stack Columns "A", "E", "I", "M", "Q", which are the names that I would like to have over at Column U (Stacked Names)!

 

[kevin9999]

Kevin.

Could you also help me out with the code to stack Columns "A", "E", "I", "M", "Q", which are the names that I would like to have over at Column U (Stacked Names)!

It already does that.
Before:

test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
1	Name	InsertWeightage	5%		Name	InsertWeightage	8%		Name	InsertWeightage	10%		Name	InsertWeightage	5%		Name	InsertWeightage	10%		Stacked Names	Stacked %
2
3	John		1%		Jonathan		1%		Gabriel		2%		John		1%		Sky		3%
4	Peter		1%		Daniel		1%		Daniel		2%		Jonathan		1%		Luke		2%
5	Andrew		1%		Damien		1%		Andrew		1%		Luke		1%		Peter		1%
6	Luke		1%		John		1%		Luke		1%		Gabriel		1%		John		3%
7	Sky		1%		Luke		1%		Sky		2%		Gerard		1%		Johnny		2%
8	Mark		0%		Mark		1%		Edward		2%
9	Mike		0%		Mike		1%
10	Gabriel		0%
11
Sheet1

Cell Formulas
Range	Formula
S3	S3	=ROW()/100

After:

test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
1	Name	InsertWeightage	5%		Name	InsertWeightage	8%		Name	InsertWeightage	10%		Name	InsertWeightage	5%		Name	InsertWeightage	10%		Stacked Names	Stacked %
2																					John	6%
3	John		1%		Jonathan		1%		Gabriel		2%		John		1%		Sky		3%		Peter	2%
4	Peter		1%		Daniel		1%		Daniel		2%		Jonathan		1%		Luke		2%		Andrew	2%
5	Andrew		1%		Damien		1%		Andrew		1%		Luke		1%		Peter		1%		Luke	6%
6	Luke		1%		John		1%		Luke		1%		Gabriel		1%		John		3%		Sky	6%
7	Sky		1%		Luke		1%		Sky		2%		Gerard		1%		Johnny		2%		Mark	1%
8	Mark		0%		Mark		1%		Edward		2%										Mike	1%
9	Mike		0%		Mike		1%														Gabriel	3%
10	Gabriel		0%																		Jonathan	2%
11																					Daniel	3%
12																					Damien	1%
13																					Edward	2%
14																					Gerard	1%
15																					Johnny	2%
16
Sheet1

Cell Formulas
Range	Formula
S3	S3	=ROW()/100