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

DA! "Jones" s/b before "Smith" as my brain did not sort.

(E-Mail Removed) wrote:

>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

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-Mail Removed)> skrev i meddelelsen
news:(E-Mail Removed)...
> 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

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

"Per Jessen" <(E-Mail Removed)> wrote:

>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-Mail Removed)> skrev i meddelelsen
>news:(E-Mail Removed)...
>> 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

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" <(E-Mail Removed)>
'
'
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!



"Per Jessen" <(E-Mail Removed)> wrote:

>Per Jessen" <(E-Mail Removed)>

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





On 19 Aug., 14:50, Eagle...@discussions.microsoft.com wrote:
> 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" <per.jes...@mail.dk>
> * *'
> * *'
> * *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!
>
>
>
> "Per Jessen" <per.jes...@mail.dk> wrote:
> >Per Jessen" <per.jes...@mail.dk>- Skjul tekst i anførselstegn -
>
> - Vis tekst i anførselstegn -

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

Per Jessen <(E-Mail Removed)> wrote:

>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
>
>
>
>
>
>On 19 Aug., 14:50, Eagle...@discussions.microsoft.com wrote:
>> 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" <per.jes...@mail.dk>
>> * *'
>> * *'
>> * *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!
>>
>>
>>
>> "Per Jessen" <per.jes...@mail.dk> wrote:
>> >Per Jessen" <per.jes...@mail.dk>- Skjul tekst i anførselstegn -
>>
>> - Vis tekst i anførselstegn -