I'm new to Macros. I'm trying to analyze the time spent by each system for a defect if the defect spans across multiple systems. I have the information stored as single row for each defect where in each system is represented as a column header
I need the defect details in multiple rows. Say defect1 spans across 3 systems then I need 3 rows for the defect1 with the system names separated. Enclosing the sample xls with the current view and desired output.
Re: Transposing column information into multiple rows
Excel 2010 (only) PivotTable, Tables
Transpose columns to rows
No formulas, no code needed.
http://c3017412.r12.cf0.rackcdn.com/02_25_11.xlsm
If you get *.zip, don't unzip, just rename *.xlsm
http://www.mediafire.com/file/tyyy14chn4r2vo8/02_25_11.pdf
Re: Transposing column information into multiple rows
Thanks. But I'm using Excel 2003. Is there a way to perform this in Excel 2003.
Re: Transposing column information into multiple rows
try
Sub Consolidate()
Dim rngCells As Range
Dim rngCol As Range
Dim rngRow As Range
Dim wks As Worksheet
If ActiveSheet.Name = "Output" Then
MsgBox "Please activate the Defects Table sheet", vbOKOnly, "Defects Table"
Exit Sub
End If
On Error Resume Next
With Cells.Find(What:="Defect ID", LookAt:=xlWhole).Offset(1)
Set rngCells = .Resize(.CurrentRegion.Rows.Count - 2, 9)
End With
Err.Clear: On Error GoTo -1: On Error GoTo 0
If rngCells Is Nothing Then
MsgBox "Unable to find the Defects Table", vbInformation + vbOKOnly, "Defects Table"
Exit Sub
End If
On Error Resume Next
Set wks = Worksheets("Output")
Err.Clear: On Error GoTo -1: On Error GoTo 0
If Not wks Is Nothing Then
wks.Cells.Clear
Else
Set wks = Worksheets.Add(After:=Worksheets(Sheets.Count))
wks.Name = "Output"
End If
rngCells.Parent.Activate
wks.Range("A1").Resize(1, 4).Value = Array("Defect ID", "Project", "System Working On Defect", "Time Spent")
For Each rngRow In rngCells.Columns(1).Cells
For Each rngCol In rngRow.Offset(, 4).Resize(1, 5).Cells
If rngCol.Value <> 0 Then
wks.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(1, 4).Value = Array(Cells(rngCol.Row, 1).Value, Cells(rngCol.Row, 2).Value, Cells(rngCol.Row, 3).Value, rngCol.Value)
End If
Next rngCol
Next rngRow
wks.Activate
Set wks = Nothing
Set rngCells = Nothing
Set rngCol = Nothing
Set rngRow = Nothing
End SubRe: Transposing column information into multiple rows
Thanks for the reply. It worked fine for the sample I had enclosed earlier. I tried to extend the same code for a larger sample with 150+ defects and Systems spanning till col DB. But the code missed some defects ( which I have highlighted in Yellow in the enclosed xls) and also for the defects where the time spent was available in systems coming after Col I it didn't add those times. Is there a way that I can extend this code till excel limit of Col.
Re: Transposing column information into multiple rows
lgomathi, this is why it is important to divulge as much information as possible about the data. There was no indication that the columns would by dynamic.
Try this. I have modified the code to work for varying number of columns
Sub Consolidate()
Dim rngCells As Range
Dim rngCol As Range
Dim rngRow As Range
Dim wks As Worksheet
Dim lngColumns As Long
If ActiveSheet.Name = "Output" Then
MsgBox "Please activate the Defects Table sheet", vbOKOnly, "Defects Table"
Exit Sub
End If
On Error Resume Next
With Cells.Find(What:="Defect ID", LookAt:=xlWhole).Offset(1)
lngColumns = .Offset(-1).End(xlToRight).Column - 4
Set rngCells = .Resize(.CurrentRegion.Rows.Count - 2, 9)
End With
Err.Clear: On Error GoTo -1: On Error GoTo 0
If rngCells Is Nothing Then
MsgBox "Unable to find the Defects Table", vbInformation + vbOKOnly, "Defects Table"
Exit Sub
End If
On Error Resume Next
Set wks = Worksheets("Output")
Err.Clear: On Error GoTo -1: On Error GoTo 0
If Not wks Is Nothing Then
wks.Cells.Clear
Else
Set wks = Worksheets.Add(After:=Worksheets(Sheets.Count))
wks.Name = "Output"
End If
rngCells.Parent.Activate
wks.Range("A1").Resize(1, 4).Value = Array("Defect ID", "Project", "System Working On Defect", "Time Spent")
For Each rngRow In rngCells.Columns(1).Cells
For Each rngCol In rngRow.Offset(, 4).Resize(1, lngColumns).Cells
If rngCol.Value <> 0 Then
wks.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(1, 4).Value = Array(Cells(rngCol.Row, 1).Value, Cells(rngCol.Row, 2).Value, Cells(rngCol.Row, 3).Value, rngCol.Value)
End If
Next rngCol
Next rngRow
wks.Activate
Set wks = Nothing
Set rngCells = Nothing
Set rngCol = Nothing
Set rngRow = Nothing
End SubRe: Transposing column information into multiple rows
Thanks for your help. It worked like magic. I made the following changes.
1. The last row was not getting counted. So modified Set rngCells = .Resize(.CurrentRegion.Rows.Count - 1, 9)
2. To get the system name based on col header
wks.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(1, 4).Value = Array(Cells(rngCol.Row, 1).Value, Cells(rngCol.Row, 2).Value, Cells(1,rngCol.Column).Value, rngCol.Value)
This was the final piece of your code which I used after the above modification and it worked.Thanks again
Sub Consolidate()
Dim rngCells As Range
Dim rngCol As Range
Dim rngRow As Range
Dim wks As Worksheet
Dim lngColumns As Long
If ActiveSheet.Name = "Output" Then
MsgBox "Please activate the Defects Table sheet", vbOKOnly, "Defects Table"
Exit Sub
End If
On Error Resume Next
With Cells.Find(What:="Defect ID", LookAt:=xlWhole).Offset(1)
lngColumns = .Offset(-1).End(xlToRight).Column - 4
Set rngCells = .Resize(.CurrentRegion.Rows.Count - 1, 9)
End With
Err.Clear: On Error GoTo -1: On Error GoTo 0
If rngCells Is Nothing Then
MsgBox "Unable to find the Defects Table", vbInformation + vbOKOnly, "Defects Table"
Exit Sub
End If
On Error Resume Next
Set wks = Worksheets("Output")
Err.Clear: On Error GoTo -1: On Error GoTo 0
If Not wks Is Nothing Then
wks.Cells.Clear
Else
Set wks = Worksheets.Add(After:=Worksheets(Sheets.Count))
wks.Name = "Output"
End If
rngCells.Parent.Activate
wks.Range("A1").Resize(1, 4).Value = Array("Defect ID", "Project", "System Working On Defect", "Time Spent")
For Each rngRow In rngCells.Columns(1).Cells
For Each rngCol In rngRow.Offset(, 4).Resize(1, lngColumns).Cells
If rngCol.Value <> 0 Then
wks.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(1, 4).Value = Array(Cells(rngCol.Row, 1).Value, Cells(rngCol.Row, 2).Value, Cells(1, rngCol.Column).Value, rngCol.Value)
End If
Next rngCol
Next rngRow
wks.Activate
Set wks = Nothing
Set rngCells = Nothing
Set rngCol = Nothing
Set rngRow = Nothing
End Sub
Don’t have an account yet? Register yourself now and be a part of our community!