Array + Transpose + Table

Excel_pal

New Member
Joined
Mar 14, 2014
Messages
19
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>
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Here's a formula version if suits, You could data validate the project names in A1 Sheet 2.


Book1
ABCDE
1ProjectOwnerStatusRiskTeam
2AJackOn TrackNoneNone
3BMaryRIskShort on fundingJoe, Mary, Mira
4CVickNeed HelpNeed more resourcesKayle, Mike
Sheet1



Book1
AB
1A
2OwnerJack
3StatusOn Track
4RiskNone
5TeamNone
Sheet2
Cell Formulas
RangeFormula
B2=INDEX(Sheet1!$B$2:$E$4,MATCH($A$1,Sheet1!$A$2:$A$4,0),MATCH($A2,Sheet1!$B$1:$E$1,0))
 
Upvote 0
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:


Book1
ABCDE
1ProjectOwnerStatusRiskTeam
2AJackOn TrackNoneNone
3BMaryRIskShort on fundingJoe, Mary, Mira
4CVickNeed HelpNeed more resourcesKayle, Mike
Sheet1



And Data in sheet2 like this:


Book1
ABC
1CButton Here
2
3
4
Sheet2
 
Last edited:
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,506
Messages
6,114,027
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top