|
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 |
VBA to delete Duplicate Records (1 column), before which, non-duplicate data merged into remaining row
|
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 |
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 |
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" |
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 - |
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 - |
| All times are GMT +1. The time now is 04:21 AM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com