Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 391
Default VBA to delete Duplicate Records (1 column), before which, non-duplicate data merged into remaining row

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
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 391
Default VBA to delete Duplicate Records (1 column), before which, non-duplicate data merged into remaining row

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

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

  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 1,533
Default VBA to delete Duplicate Records (1 column), before which, non-duplicate data merged into remaining row

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


  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 391
Default VBA to delete Duplicate Records (1 column), before which, non-duplicate data merged into remaining row

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" 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(xlCellTypeV isible).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

  #5   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 391
Default VBA to delete Duplicate Records (1 column), before which, non-duplicate data merged into remaining row

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"



  #6   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 703
Default VBA to delete Duplicate Records (1 column), before which,non-duplicate data merged into remaining row

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 -


  #7   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 391
Default VBA to delete Duplicate Records (1 column), before which, non-duplicate data merged into remaining row

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

Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Delete records when certain records have duplicate column data JVroom New Users to Excel 1 January 26th 09 06:23 PM
Delete Duplicate records Finger Tips Excel Worksheet Functions 2 April 29th 07 08:42 PM
how to delete duplicate records in a row Christian Setting up and Configuration of Excel 2 July 21st 06 01:39 AM
Delete row where there is duplicate data in Column E SITCFanTN New Users to Excel 1 June 4th 06 09:35 AM
Delete Duplicate Records Jamie Collins Excel Programming 0 July 13th 04 12:34 PM


All times are GMT +1. The time now is 02:33 AM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"