Array + Transpose + Table

[Excel_pal]

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)
[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Project[/TD]
[TD]Owner[/TD]
[TD]Status[/TD]
[TD]Risk[/TD]
[TD]Team[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]A[/TD]
[TD]Jack[/TD]
[TD]On Track[/TD]
[TD]None[/TD]
[TD]None[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]B[/TD]
[TD]Mary[/TD]
[TD]RIsk[/TD]
[TD]Short on funding[/TD]
[TD]Joe, Mary, Mira[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]C[/TD]
[TD]Vick[/TD]
[TD]Need Help[/TD]
[TD]Need more resources[/TD]
[TD]Kayle, Mike[/TD]
[/TR]
</tbody>[/TABLE]

Sheet 2:

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Project Name[/TD]
[TD]Button/Function (Create Summary)[/TD]
[/TR]
</tbody>[/TABLE]


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


[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Project[/TD]
[TD]Project A[/TD]
[/TR]
[TR]
[TD]Owner[/TD]
[TD]Jack[/TD]
[/TR]
[TR]
[TD]Status[/TD]
[TD]On Track[/TD]
[/TR]
[TR]
[TD]Risk[/TD]
[TD]None[/TD]
[/TR]
[TR]
[TD]Team[/TD]
[TD]None[/TD]
[/TR]
</tbody>[/TABLE]

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;">[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Project Name[/TD]
[TD]Button/Function (Create Summary)

[/TD]
[/TR]
</tbody>[/TABLE]
</body>

 

[RasGhul]

Here's a formula version if suits, You could data validate the project names in A1 Sheet 2.

Book1
	A	B	C	D	E
1	Project	Owner	Status	Risk	Team
2	A	Jack	On Track	None	None
3	B	Mary	RIsk	Short on funding	Joe, Mary, Mira
4	C	Vick	Need Help	Need more resources	Kayle, Mike
Sheet1

Book1
	A	B
1	A
2	Owner	Jack
3	Status	On Track
4	Risk	None
5	Team	None
Sheet2

Cell Formulas
Range	Formula
B2	=INDEX(Sheet1!$B$2:$E$4,MATCH($A$1,Sheet1!$A$2:$A$4,0),MATCH($A2,Sheet1!$B$1:$E$1,0))

 

[Nishant94]

You can use this code in a button (In case you need VBA):

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:

Book1
	A	B	C	D	E
1	Project	Owner	Status	Risk	Team
2	A	Jack	On Track	None	None
3	B	Mary	RIsk	Short on funding	Joe, Mary, Mira
4	C	Vick	Need Help	Need more resources	Kayle, Mike
Sheet1

And Data in sheet2 like this:

Book1
	A	B	C
1	C	Button Here
2
3
4
Sheet2

 

[Excel_pal]

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]

[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]

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]

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]

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]

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?

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.

 

[RasGhul]

Here's a dropbox link to a mockup table version with a guide to how it is made for reference for your sheet.

Note that you should make a copy of your original file and see if you like the end result first before applying to your real file.


https://www.dropbox.com/s/6zm758ke1ahqb8n/array_transpose_table_Excel_pal_table_version.xlsx?dl=0