VBA to delete Duplicate Records (1 column), before which, non-duplicate data merged into remaining r

E

EagleOne

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
 
P

Per Jessen

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(xlCellTypeVisible).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
 
E

EagleOne

Just awakened and saw your solution. I'l be attempting it in a few hours.

I knew that there had to be a "array" technique. My old brain, does not think well in array
concepts.

I'll post back with results in a few hours. Thanks!

EagleOne
 
E

EagleOne

Per,

Except for my Dim some variables, the code is yours i.e.:
Did I "Dim" properly?

Your code worked for the first 623 records; but failed here:

RECORD

622 HolecekElizabeth(999) x62-1121
623 HolecekElizabeth(999) x62-1121 (value of Range("A" & r).Value at failure)
624 HolecekElizabeth(999) x62-1121
625 HolecekElizabeth(999) x62-1121
626 HolecekElizabeth(999) x62-1121
627 HolecekElizabeth(999) x62-1121




Sub ConsolPersonTalents()
'
'Subject: Re: VBA to delete Duplicate Records (1 column) Date: Wed, 19 Aug 2009 09:22:17 +0200
'Date: Wed, 19 Aug 2009 09:22:17 +0200 Per Jessen" <[email protected]>
'
'
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 namecounter As Long
Dim r As Long
Dim c As Long
Dim col As Long
Dim myArr()
Dim TargetName As String
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(xlCellTypeVisible).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
'************ FAILS here at Record 623 "Subscript out of Range, then "Device I/O error"
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

Thanks!
 
P

Per Jessen

EagleOne,

The Dim statements looks fine, and as it is working for 623 records it
should not be the problem.

What is the value of 'NameCounter' and 'UniqueNames' when the code
fails? I suspect that they are equal, and that the upper bound for
MyArr has been reached for some reason.


If you want you can me a sample sheet, and I will give it a look.

Regards,
Per
 
E

EagleOne

Per,

Exactly what I thought (623 successful).

Now that I know I Dim'ed OK, I'll try again tomorrow morning.

I will try to debug myself but I may need your help. Thanks

EagleOne
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

How to add condition to coding? 1
Setting "r" to = range selected in an IF statement? 4
Set worksheet range runtime error 1004 2
Code lagging with LastRow 2
Polulating Combobox's 3
Transfer array element offset value to a matched value 3
Hope to stock data at every single update&all the sheets stocking synchronized 5
How to find text within a range of values? 5

Top