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, 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 he

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: 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"
* *'
* *'
* *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(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 * *
'************ 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" wrote:
Per Jessen" - Skjul tekst i anførselstegn -

- Vis tekst i anførselstegn -