2003-2007


CHALLENGE:
1) A w/s has 68 columns
2) I wish to delete duplicative rows (criteria for duplicates is values in Column A)
3) In the remaining 67 columns, there should be "X" and "O", one each, in every column but in
different rows
4) The data is sorted by column 1 values

i.e.

TABLE BEFORE PROCESSING: (6 Records)
Column A B C D E F G

Smith X
Smith O
Smith X
Smith O
Smith X
Jones X

TABLE AFTER PROCESSING: (Two Records)
Column A B C D E F G
Smith X O X O X (The data in Col's B thru G merged to the first record)
Jones X

Below is inefficient code to do above:

Sub ConsolPersonTalents()
'
' Created 8/18/2009 and Updated through 8/18/2009 by Dennis Burgess CPA
'

Dim myRowsToProcess As Long, myColumnsToProcess As Long
Dim myOrigSheetProtectStatus As Boolean
Dim MaxRows As Long
Dim MaxColumns As Long
Dim myCell As Range
Dim myRange As Range

On Error Resume Next
Cells.SpecialCells(xlConstants, 23).Select
If Not Err.Number 0 Then
With ActiveSheet
MaxRows = .Rows.Count
MaxColumns = .Columns.Count
End With
myRowsToProcess = Cells.Find(What:="*", After:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
myColumnsToProcess = Cells.Find(What:="*", After:=ActiveSheet.Cells(1, 1),
LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
myRowsToProcess = IIf(myRowsToProcess MaxRows, MaxRows, myRowsToProcess)
myColumnsToProcess = IIf(myColumnsToProcess MaxColumns, MaxColumns, myColumnsToProcess)
Else
MsgBox ActiveSheet.Name & " is Empty!"
End If
Range(Cells(1, myColumnsToProcess + 1), Cells(65536, 256)).EntireColumn.Delete
Range(Cells(myRowsToProcess + 1, 1), Cells(65536, 256)).EntireRow.Delete
ActiveSheet.UsedRange ' refers to the UsedRange and resets it
Set myRange = Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp))
For Each myCell In myRange
If myCell.Value = myCell.Offset(1, 0).Value Then
Stop
If myCell.Offset(0, 21).Value = "" And myCell.Offset(1, 21).Value < "" Then
myCell.Offset(0, 21).Value = myCell.Offset(1, 21).Value
End If
If myCell.Offset(0, 22).Value = "" And myCell.Offset(1, 22).Value < "" Then
myCell.Offset(0, 22).Value = myCell.Offset(1, 22).Value
End If
If myCell.Offset(0, 23).Value = "" And myCell.Offset(1, 23).Value < "" Then
myCell.Offset(0, 23).Value = myCell.Offset(1, 23).Value
End If
ActiveSheet.Cells(myCell.Offset(1, 21).Row, 1).EntireRow.Delete
Set myRange = Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp))
End If

....................
....................
....................
....................
....................

Next myCell
End Sub

Any thoughts/betterments appreciated. (There must be smarter code!?)

TIA EagleOne