PDA

View Full Version : [SOLVED:] Transpose Nested Data



willhh3
04-14-2015, 11:19 AM
Hoping someone can help with this, it is way beyond my skill level. We have a set group of folk that approve tickets each week. The received comes in a stacked or nested format and I would like to get in in a single row so that I can sort on different columns. I don't want to use grouping. The attached file show a tab with the end result I'm looking for (Report tab) and I've added some notes there. The second tab contains the data/votes and is called Votes. I've also placed some notes there based on differing conditions. I'm not sure if this is doable, other than manually, but thought it was worth the ask. There are also some complication like the person may not vote, they may vote twice or the may defer the vote.

Here's simple view, but the uploaded file is better.

Votes:
Ticket #: 123

Person A Approve
Person B Approve
Person C Approve


Report tab:

Ticket # Person A Person B Person C
123 Approve Approve Approve

Thanks in advance for any help.
Whh3

p45cal
04-15-2015, 04:53 PM
try the following macro on your sample file:
Sub blah()
Sheets("Votes").Copy after:=Sheets(Sheets.Count)
Set NewSht = ActiveSheet
Set ddd = NewSht.ListObjects(1)
With ddd
.Range.AutoFilter
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.ListColumns("RFC #").Range, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.ListColumns("Last Name").DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.ListColumns("Date").DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.ListColumns("Time").DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
RFCColm = ddd.ListColumns("RFC #").Index
DateColm = ddd.ListColumns("Date").Index
TimeColm = ddd.ListColumns("Time").Index
LNameColm = ddd.ListColumns("Last Name").Index
VoteColm = ddd.ListColumns("Vote").Index
For lrw = ddd.ListRows.Count To 2 Step -1
Set xxx = ddd.ListRows(lrw).Range
Set yyy = xxx.Offset(-1)
'xxx.Select
If Trim(xxx.Cells(RFCColm).Value) = "" Then
ddd.ListRows(lrw).Delete
Else
If xxx.Cells(RFCColm).Value = yyy.Cells(RFCColm).Value Then
If xxx.Cells(LNameColm).Value = yyy.Cells(LNameColm).Value Then
If (xxx.Cells(DateColm).Value + xxx.Cells(TimeColm).Value) > (yyy.Cells(DateColm).Value + yyy.Cells(TimeColm).Value) Then
'delete lesser row
'yyy.Select
ddd.ListRows(lrw - 1).Delete
Else
'xxx.Select
ddd.ListRows(lrw).Delete
End If
End If
End If
End If
Next lrw
Set ReportSht = Sheets.Add(after:=Sheets(Sheets.Count))
Set DestnTopLeftCell = ReportSht.Range("B3")
LastNameArray = Array("Person A", "Person B", "Person C", "Person D", "Person E", "Person F", "Person G")
ddd.ListColumns("RFC #").Range.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=DestnTopLeftCell, Unique:=True
RFCArray = Application.Transpose(Range(DestnTopLeftCell, DestnTopLeftCell.End(xlDown)).Value)
DestnTopLeftCell.Offset(, 6).Resize(, 7) = LastNameArray
For Each lrow In ddd.ListRows
RFCNo = lrow.Range.Cells(RFCColm).Value
LName = lrow.Range.Cells(LNameColm).Value
x = -1: y = -1
x = Application.Match(LName, LastNameArray, 0)
y = Application.Match(RFCNo, RFCArray, 0)
If x > -1 And y > -1 Then
myVal = ""
Select Case Trim(lrow.Range.Cells(VoteColm).Value)
Case "Approve": myVal = "x"
Case "Defer": myVal = "D"
Case "": myVal = ""
Case Else: myVal = "??"
End Select
DestnTopLeftCell.Offset(y - 1, 6 + x - 1).Value = myVal
End If
Next lrow
DestnTopLeftCell.Offset(1, 2).Resize(UBound(RFCArray) - 1).FormulaR1C1 = "=COUNTIF(RC[4]:RC[10], ""x"")&""/""&7"
DestnTopLeftCell.Offset(1, 3).Resize(UBound(RFCArray) - 1).FormulaR1C1 = "=COUNTIF(RC[3]:RC[9], ""D"")"
DestnTopLeftCell.Offset(1, 5).Resize(UBound(RFCArray) - 1).FormulaR1C1 = "=RC[-5]"
DestnTopLeftCell.Offset(1, 13).Resize(UBound(RFCArray) - 1).FormulaR1C1 = "=RC[-13]"
Application.DisplayAlerts = False
NewSht.Delete
Application.DisplayAlerts = True
Application.Goto DestnTopLeftCell
End Sub

willhh3
04-16-2015, 05:49 AM
P.S. Re-reading my post...sorry for the type-o's!!! Geez, I need to proof before hitting that send button!

willhh3
04-16-2015, 05:51 AM
P.S.S. Still amazed and thanks for the timely solution!!!