Array + Transpose + Table

Excel_pal

New Member
Joined
Mar 14, 2014
Messages
18
Excel Champs,

Looking for creative solves for the below problem. I have a project sheet that looks something likes below in a table. I need a button function that can transfer in a separate sheet all the values in that row for that project transposed in a column.

Master file (Sheet 1)
ABCDE
1ProjectOwnerStatusRiskTeam
2AJackOn TrackNoneNone
3BMaryRIskShort on fundingJoe, Mary, Mira
4CVickNeed HelpNeed more resourcesKayle, Mike

<tbody>
</tbody>

Sheet 2:

AB
1Project NameButton/Function (Create Summary)

<tbody>
</tbody>


Example: If Project is selected in sheet 2 cell A1, the outcome below should be in a separate sheet:


ProjectProject A
OwnerJack
StatusOn Track
RiskNone
TeamNone

<tbody>
</tbody>

Any help on this, would greatly appreciate it.
Thank you.
****** id="cke_pastebin" style="position: absolute; top: 0px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">
AB
1Project NameButton/Function (Create Summary)


<tbody>
</tbody>
</body>
 

RasGhul

Well-known Member
Joined
Jul 15, 2016
Messages
608
Here's a formula version if suits, You could data validate the project names in A1 Sheet 2.

<b></b><table cellpadding="2.5px" rules="all" style=";background-color: rgb(255,255,255);border: 1px solid;border-collapse: collapse; border-color: rgb(187,187,187)"><colgroup><col width="25px" style="background-color: rgb(218,231,245)" /><col /><col /><col /><col /><col /></colgroup><thead><tr style=" background-color: rgb(218,231,245);text-align: center;color: rgb(22,17,32)"><th></th><th>A</th><th>B</th><th>C</th><th>D</th><th>E</th></tr></thead><tbody><tr ><td style="color: rgb(22,17,32);text-align: center;">1</td><td style="font-weight: bold;;">Project</td><td style="font-weight: bold;;">Owner</td><td style="font-weight: bold;;">Status</td><td style="font-weight: bold;;">Risk</td><td style="font-weight: bold;;">Team</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">2</td><td style=";">A</td><td style=";">Jack</td><td style=";">On Track</td><td style=";">None</td><td style=";">None</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">3</td><td style=";">B</td><td style=";">Mary</td><td style=";">RIsk</td><td style=";">Short on funding</td><td style=";">Joe, Mary, Mira</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">4</td><td style=";">C</td><td style=";">Vick</td><td style=";">Need Help</td><td style=";">Need more resources</td><td style=";">Kayle, Mike</td></tr></tbody></table><p style="width:4.8em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid rgb(187,187,187);border-top:none;text-align: center;background-color: rgb(218,231,245);color: rgb(22,17,32)">Sheet1</p><br /><br />

<b></b><table cellpadding="2.5px" rules="all" style=";background-color: rgb(255,255,255);border: 1px solid;border-collapse: collapse; border-color: rgb(187,187,187)"><colgroup><col width="25px" style="background-color: rgb(218,231,245)" /><col /><col /></colgroup><thead><tr style=" background-color: rgb(218,231,245);text-align: center;color: rgb(22,17,32)"><th></th><th>A</th><th>B</th></tr></thead><tbody><tr ><td style="color: rgb(22,17,32);text-align: center;">1</td><td style="font-weight: bold;;">A</td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">2</td><td style="font-weight: bold;;">Owner</td><td style=";">Jack</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">3</td><td style="font-weight: bold;;">Status</td><td style=";">On Track</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">4</td><td style="font-weight: bold;;">Risk</td><td style=";">None</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">5</td><td style="font-weight: bold;;">Team</td><td style=";">None</td></tr></tbody></table><p style="width:4.8em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid rgb(187,187,187);border-top:none;text-align: center;background-color: rgb(218,231,245);color: rgb(22,17,32)">Sheet2</p><br /><br /><table width="85%" cellpadding="2.5px" rules="all" style=";border: 2px solid black;border-collapse:collapse;padding: 0.4em;background-color: rgb(255,255,255)" ><tr><td style="padding:6px" ><b>Worksheet Formulas</b><table cellpadding="2.5px" width="100%" rules="all" style="border: 1px solid;text-align:center;background-color: rgb(255,255,255);border-collapse: collapse; border-color: rgb(187,187,187)"><thead><tr style=" background-color: rgb(218,231,245);color: rgb(22,17,32)"><th width="10px">Cell</th><th style="text-align:left;padding-left:5px;">Formula</th></tr></thead><tbody><tr><th width="10px" style=" background-color: rgb(218,231,245);color: rgb(22,17,32)">B2</th><td style="text-align:left">=INDEX(<font color="Blue">Sheet1!$B$2:$E$4,MATCH(<font color="Red">$A$1,Sheet1!$A$2:$A$4,0</font>),MATCH(<font color="Red">$A2,Sheet1!$B$1:$E$1,0</font>)</font>)</td></tr></tbody></table></td></tr></table><br />
 

Nishant94

Well-known Member
Joined
May 8, 2015
Messages
507
You can use this code in a button (In case you need VBA):

Code:
Sub Create_Summary()


Dim arr As Variant
Dim wk As Worksheet
Dim header As Variant, final_arr As Variant
Dim x As Integer, y As Integer
Dim check As Boolean


Application.DisplayAlerts = False
arr = Sheets("Sheet1").Range("A1").CurrentRegion
ReDim final_arr(1 To (UBound(arr, 2) - 1), 1 To 1)
On Error Resume Next
Sheets("" & Sheets("Sheet2").Range("A1") & "").Delete
Set wk = Worksheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
Application.DisplayAlerts = True
On Error GoTo 0
wk.Name = Sheets("Sheet2").Range("A1")
x = 1
Do
    If arr(x, 1) = Sheets("Sheet2").Range("A1").Value Then
        For y = 2 To UBound(arr, 2)
            final_arr(y - 1, 1) = arr(x, y)
        Next y
        check = True
    End If
    x = x + 1
Loop While check = False
Sheets("Sheet1").Range("B1").Resize(1, UBound(arr, 2) - 1).Copy
wk.Range("A1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
wk.Range("B1").Resize(UBound(final_arr, 1), 1).Value = final_arr


End Sub
Assuming you have data in sheet1 like this:

<b></b><table cellpadding="2.5px" rules="all" style=";background-color: rgb(255,255,255);border: 1px solid;border-collapse: collapse; border-color: rgb(187,187,187)"><colgroup><col width="25px" style="background-color: rgb(218,231,245)" /><col /><col /><col /><col /><col /></colgroup><thead><tr style=" background-color: rgb(218,231,245);text-align: center;color: rgb(22,17,32)"><th></th><th>A</th><th>B</th><th>C</th><th>D</th><th>E</th></tr></thead><tbody><tr ><td style="color: rgb(22,17,32);text-align: center;">1</td><td style=";">Project</td><td style=";">Owner</td><td style=";">Status</td><td style=";">Risk</td><td style=";">Team</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">2</td><td style=";">A</td><td style=";">Jack</td><td style=";">On Track</td><td style=";">None</td><td style=";">None</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">3</td><td style=";">B</td><td style=";">Mary</td><td style=";">RIsk</td><td style=";">Short on funding</td><td style=";">Joe, Mary, Mira</td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">4</td><td style=";">C</td><td style=";">Vick</td><td style=";">Need Help</td><td style=";">Need more resources</td><td style=";">Kayle, Mike</td></tr></tbody></table><p style="width:4.8em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid rgb(187,187,187);border-top:none;text-align: center;background-color: rgb(218,231,245);color: rgb(22,17,32)">Sheet1</p><br /><br />


And Data in sheet2 like this:

<b></b><table cellpadding="2.5px" rules="all" style=";background-color: rgb(255,255,255);border: 1px solid;border-collapse: collapse; border-color: rgb(187,187,187)"><colgroup><col width="25px" style="background-color: rgb(218,231,245)" /><col /><col /><col /></colgroup><thead><tr style=" background-color: rgb(218,231,245);text-align: center;color: rgb(22,17,32)"><th></th><th>A</th><th>B</th><th>C</th></tr></thead><tbody><tr ><td style="color: rgb(22,17,32);text-align: center;">1</td><td style=";">C</td><td style="font-weight: bold;color: #FFFFFF;background-color: #00B0F0;;">Button Here</td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">2</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">3</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr><tr ><td style="color: rgb(22,17,32);text-align: center;">4</td><td style="text-align: right;;"></td><td style="text-align: right;;"></td><td style="text-align: right;;"></td></tr></tbody></table><p style="width:4.8em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid rgb(187,187,187);border-top:none;text-align: center;background-color: rgb(218,231,245);color: rgb(22,17,32)">Sheet2</p><br /><br />
 
Last edited:

Excel_pal

New Member
Joined
Mar 14, 2014
Messages
18
Thank you both!
RasGhul: What is in A2 cell in sheet2. Right now, its blank. Should I drag the formula in the column to B5?

Nishant, the VBA worked great. Not quite my strenght, but I managed to make this run. Thank you. Question though - what do I change in the code if the sheet 1 table starts from B7 to X7 and down to 25 rows? What if down the road I add more columns and rows? Can you highlight the section in the code that I can change?
 

Nishant94

Well-known Member
Joined
May 8, 2015
Messages
507
Code:
[COLOR=#333333][FONT=Verdana]
Sub Create_Summary()

Dim arr As Variant
Dim wk As Worksheet
Dim header As Variant, final_arr As Variant
Dim x As Integer, y As Integer
Dim check As Boolean


Application.DisplayAlerts = False
arr = Sheets("Sheet1").Range("[/FONT][/COLOR][COLOR=#ff0000][FONT=Verdana]A1[/FONT][/COLOR][COLOR=#333333][FONT=Verdana]").CurrentRegion
ReDim final_arr(1 To (UBound(arr, 2) - 1), 1 To 1)
On Error Resume Next
Sheets("" & Sheets("Sheet2").Range("A1") & "").Delete
Set wk = Worksheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
Application.DisplayAlerts = True
On Error GoTo 0
wk.Name = Sheets("Sheet2").Range("A1")
x = 1
Do
    If arr(x, 1) = Sheets("Sheet2").Range("A1").Value Then
        For y = 2 To UBound(arr, 2)
            final_arr(y - 1, 1) = arr(x, y)
        Next y
        check = True
    End If
    x = x + 1
Loop While check = False
Sheets("Sheet1").Range("[/FONT][/COLOR][COLOR=#ff0000][FONT=Verdana]A1[/FONT][/COLOR][COLOR=#333333][FONT=Verdana]").Offset(0,1).Resize(1, UBound(arr, 2) - 1).Copy
wk.Range("A1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
wk.Range("B1").Resize(UBound(final_arr, 1), 1).Value = final_arr

End Sub
[/FONT][/COLOR]
Change the red ones with the first cell from where your table starts. For example if the table is G7:X25 then replace the red coloured text with G7. Even if you add more data it will automatically pick up the new data when you run the code.
 

RasGhul

Well-known Member
Joined
Jul 15, 2016
Messages
608
Thank you both!
RasGhul: What is in A2 cell in sheet2. Right now, its blank. Should I drag the formula in the column to B5?

Nishant, the VBA worked great. Not quite my strenght, but I managed to make this run. Thank you. Question though - what do I change in the code if the sheet 1 table starts from B7 to X7 and down to 25 rows? What if down the road I add more columns and rows? Can you highlight the section in the code that I can change?
yes drag the formula down to B5, you can create a table version of this to make it dynamic if required but will need table reference change to the formula.

Nishants solution is also dynamic when setup correctly.
 

Excel_pal

New Member
Joined
Mar 14, 2014
Messages
18
yes drag the formula down to B5, you can create a table version of this to make it dynamic if required but will need table reference change to the formula.

Nishants solution is also dynamic when setup correctly.
Somehow it still is not working. I am getting #N/A in all the cells.
 

Excel_pal

New Member
Joined
Mar 14, 2014
Messages
18
Sorry to bother you again, but I changed the sheet name also in the code to match with the original file. It messed up and showing error. I only changed the file name from Sheet1 to Project_List. I do have other sheets in the file. Could that have caused error?
 

Nishant94

Well-known Member
Joined
May 8, 2015
Messages
507
Sorry to bother you again, but I changed the sheet name also in the code to match with the original file. It messed up and showing error. I only changed the file name from Sheet1 to Project_List. I do have other sheets in the file. Could that have caused error?
Code:
Sub Create_Summary()


Dim arr As Variant
Dim wk As Worksheet, tabsheet As Range, crsheet As Range
Dim header As Variant, final_arr As Variant
Dim x As Integer, y As Integer
Dim check As Boolean


'Change the sheet name from Sheet1 to anything where your table is
'and similarly change A1 to the cell reference from where your table starts
Set tabsheet = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Range("[COLOR=#ff0000]A1[/COLOR]")
'The below line of code deals with the criteria sheet and range
'So you can chage the criteria sheet name from sheet2 to anything where you have your criteria
'and range from A1 to any cell reference where you have the criteria
Set crsheet = Sheets("[COLOR=#ff0000]Sheet2[/COLOR]").Range("[COLOR=#ff0000]A1[/COLOR]")


Application.DisplayAlerts = False
arr = tabsheet.CurrentRegion
ReDim final_arr(1 To (UBound(arr, 2) - 1), 1 To 1)
On Error Resume Next
Sheets("" & crsheet & "").Delete
Set wk = Worksheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
Application.DisplayAlerts = True
On Error GoTo 0
wk.Name = crsheet
x = 1
Do
    If arr(x, 1) = crsheet.Value Then
        For y = 2 To UBound(arr, 2)
            final_arr(y - 1, 1) = arr(x, y)
        Next y
        check = True
    End If
    x = x + 1
Loop While check = False
tabsheet.Offset(0, 1).Resize(1, UBound(arr, 2) - 1).Copy
wk.Range("A1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
wk.Range("B1").Resize(UBound(final_arr, 1), 1).Value = final_arr


End Sub
I have marked the areas where you need to make changes and explained it by commenting it out in the code itself.
 

Forum statistics

Threads
1,085,645
Messages
5,384,890
Members
401,925
Latest member
temelio

Some videos you may like

This Week's Hot Topics

Top