Hi EagleOne

This solution use an array to collect data, then parse it back to the sheet
when all rows has been prosessed and sheet cleard.

As you don't tells us your exact sheet layout, I assumed you have Headings
in row 1 and data starting from row 2.

Hopes this helps.

Sub ConsolPersonTalents1()
Dim myRowsToProcess As Long, myColumnsToProcess As Long
Dim myOrigSheetProtectStatus As Boolean
Dim MaxRows As Long
Dim MaxCols As Long
Dim myCell As Range
Dim myRange As Range
Dim UniqueNames As Long
Dim myArr()
MaxRows = Range("A1").CurrentRegion.Rows.Count
MaxCols = Range("A1").CurrentRegion.Columns.Count

If MaxRows = 1 And MaxCols = 1 Then
MsgBox ActiveSheet.Name & " is Empty!"
End If
Range("A1", Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterInPlace,
Unique:=True
UniqueNames = Range("A1",
Range("A1").End(xlDown)).SpecialCells(xlCellTypeVi sible).Count - 1
ActiveSheet.ShowAllData
ReDim myArr(1 To UniqueNames, 1 To MaxCols)
TargetName = Range("A2").Value
myArr(1, 1) = TargetName
namecounter = 1

For r = 2 To MaxRows
If Range("A" & r).Value = TargetName Then
For col = 2 To MaxCols
If Cells(r, col).Value < "" Then
myArr(namecounter, col) = Cells(r, col).Value
Exit For
End If
Next
Else
namecounter = namecounter + 1
myArr(namecounter, 1) = Range("A" & r).Value
For col = 2 To MaxCols
If Cells(r, col).Value < "" Then
myArr(namecounter, col) = Cells(r, col).Value
Exit For
End If
Next
End If
Next

'Parse data to sheet
Range("A2", Cells(MaxRows, MaxCols)).ClearContents
ActiveSheet.UsedRange

For c = 1 To UBound(myArr, 1)
For r = 1 To UBound(myArr, 2)
Cells(c + 1, r) = myArr(c, r)
Next
Next
End Sub

Regards,
Per


skrev i meddelelsen
...
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