Solved: Get rid of single rows

[kathyb0527]

I have a list that contains some duplicates. I need to get rid of single occurrences and keep the duplicates. In addition, I need to then make the information linear. I can use a pivot table for that part if I can get rid of the single rows. I tried doing a pivot table, but I can't figure out how to get rid of the single rows. I've attached a basic spreadsheet with what I have (rows 1-8) and what I want it to look like (Rows 11-13). My actual information is about 1000 rows. This is (hopefully) a one time thing as the database we pulled the information from was set up wrong. Thank you for your help

[GTO]

Greetings Kathy,

Well, I sooo much should have taken off in some other direction in this, but it appears to work.

In a Standard Module:

[VBA]Option Explicit

Sub ExtendRecords()
Dim wks As Worksheet
Dim rngData As Range
Dim aryOutput As Variant
Dim TmpStr As String
Dim bolSwitch As Boolean
Dim n As Long
Dim x As Long
Dim i As Long
Dim y As Long

Set wks = ActiveSheet
With wks
Set rngData = Range(.Range("A2"), .Range("D" & .Cells(.Rows.Count, 1).End(xlUp).Row))
End With

With rngData
.Offset(, 4).Resize(, 1).Formula = "=CONCATENATE(A2,B2)"
.Offset(, 5).Resize(, 1).FormulaArray = "=COUNTIF(" & _
rngData.Offset(, 4).Resize(, 1).Address(0, 0) & _
"," & _
rngData.Offset(, 4).Resize(, 1).Address(0, 0) & _
")"
Set rngData = .Resize(, .Columns.Count + 2)
End With

With rngData
.Value = .Value
.Sort Key1:=.Cells(6), Order1:=xlDescending, _
Key2:=.Cells(2), Order2:=xlAscending, _
Key3:=.Cells(1), Order3:=xlAscending, _
Header:=xlNo
n = Application.Match(1, .Columns(6), 0)
wks.Rows(.Rows(n).Row & ":" & wks.Rows.Count).Delete
.Sort Key1:=.Cells(2), Order1:=xlAscending, _
Key2:=.Cells(1), Order2:=xlAscending, _
Key3:=.Cells(3), Order3:=xlAscending, _
Header:=xlNo
Set rngData = .Resize(n - 1)
End With

ReDim aryOutput(1 To Evaluate("SUMPRODUCT((" & _
rngData.Columns(5).Address(0, 0) & _
"<>"""")/COUNTIF(" & _
rngData.Columns(5).Address(0, 0) & _
"," & _
rngData.Columns(5).Address(0, 0) & _
"&""""))"), _
1 To 2 + (Application.Max(rngData.Columns(6)) * 2))

TmpStr = rngData.Cells(5).Value
n = 0
For x = 1 To UBound(aryOutput, 1)
aryOutput(x, 1) = rngData(1 + i, 1)
aryOutput(x, 2) = rngData(1 + i, 2)
n = 0
i = i + 1
Do While rngData(i + n, 5) = TmpStr And rngData.Rows.Count >= i
For y = 1 To 2
aryOutput(x, 2 + y + (n * 2)) = rngData(i + n, 2 + y).Value
Next
n = n + 1
Loop
TmpStr = rngData(i + n, 5)
i = i + n - 1
Next

rngData.ClearContents
rngData.Resize(UBound(aryOutput, 1), UBound(aryOutput, 2)) = aryOutput

ReDim aryOutput(1 To 1, 1 To UBound(aryOutput, 2))

aryOutput(1, 1) = "First Name"
aryOutput(1, 2) = "Last Name"

For n = 1 To UBound(aryOutput, 2) - 2
bolSwitch = Not bolSwitch
aryOutput(1, n + 2) = IIf(bolSwitch, _
"Test" & IIf(CBool(n Mod 2), Chr(32) & n / 2 + 0.5, vbNullString), _
"Score")
Next

With rngData.Resize(1, UBound(aryOutput, 2)).Offset(-1)
.Value = aryOutput
.Font.Bold = True
.HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
End With
End Sub[/VBA]

Hope that helps,

Mark

[kathyb0527]

PERFECT! Thank you so much. This also gives me a chance to learn more coding. Bonus!