PDA

View Full Version : [SLEEPER:] Sort data in one column based on value in another issue



Event2020
07-18-2024, 04:46 PM
Excel 2019


Hello everyone.

I have a worksheet with two columns that acts as a defacto "parent-child" family group relationship.

Each value in Column A has a unlimited number of "child" values in Column B some of which are the same value but some are a mix of different values.

I have tried to write code that finds each "parent" value in column A and then moves down the worksheet to find the next "parent" value and moves back up one row to obtain the range for each Parent-Child entry which, in theory at least, should work.

Then for each parent "range" it should look at the values in Column B, remove all duplicates leaving only unique values then sort each range in column B and move all values up to their parent rows.

I will then add code that removes the blank spaces in column B at a later stage once the "Remove Duplicates" code is working as needed.

I have tried a large number of variations on the code but none seem to do what I need, some even ended up removing all of the data from some of the family groups in Column B.

I feel that this should be simple but I am very fraustrated that I am unable to work it out for myself so here I am asking if anyone could help me out.

I have a attached a small Example.xslm with four Subs.

1. This removes any duplicates in the Parent Column A and it works perfectely.

Sub RemoveDuplicatesColumn_A()
' This successfully removes duplicates in Column A as per the criteria
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
' This sets the worksheet to "Example"
Set ws = ThisWorkbook.Sheets("Example")
' This locates the last used row in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' This Loops through each cell in column A from Row 2 down to the last used row
For Each cell In ws.Range("A2:B" & lastRow)
' Check if the value in the cell is duplicate
If Application.WorksheetFunction.CountIf(ws.Range("A2:A" & cell.Row), cell.Value) > 1 Then
' If duplicate is found, clear the cell
cell.ClearContents
End If
Next cell
End Sub


2. This sub is for Column B but this one collapse's Column A's structure there by breaking the defacto parent-child relationship' and, strangly, it also deletes all but two of the child values.

Sub Ver1_RemoveDuplicatesInRange()
' This sub collapse's Column A's structure there by breaking the defacto parent-child relationship'
' It also deletes all but two of the child values.
Dim ws As Worksheet
Dim lastRowB As Long
Dim rng As Range
Dim cell As Range
Dim startRow As Long
Dim endRow As Long
Dim currentRow As Long
' Sets the worksheet
Set ws = ThisWorkbook.Sheets("Example")
' Find the last row with data in column B
lastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
' Loop through column A to find the start and end rows with data to create a defacto Parent-Child range
For Each cell In ws.Range("A2:A" & lastRowB)
currentRow = cell.Row
If Not IsEmpty(cell.Value) Then
If startRow = 0 Then
startRow = currentRow
ElseIf endRow = 0 Then
endRow = currentRow - 1
Exit For
End If
End If
Next cell
' If the start and end rows are found, it should remove the duplicates in column B within each range
If startRow > 0 And endRow > 0 Then
Set rng = ws.Range("B" & startRow & ":B" & endRow)
rng.RemoveDuplicates Columns:=Array(1), Header:=xlNo
End If
' Loops through each value in column A and remove the duplicates in column B within the remembered range for each parent
For currentRow = startRow To lastRowB
If Not IsEmpty(ws.Range("A" & currentRow).Value) Then
Set rng = ws.Range("B" & currentRow & ":B" & endRow)
rng.RemoveDuplicates Columns:=Array(1), Header:=xlNo
End If
Next currentRow
End Sub


3. This sub is also for Column B but it produces a Run-time error '1004': Method 'AddCustomList' of object'_Application' failed on line "Application.AddCustomList ListArray:=sortOrder".
To try and cure it I passed the values of the sortOrder range to Application.AddCustomList, .Value to reference the values rather than the range itself but I still get the run-time error.

Sub Ver2_RemoveDuplicatesInRange()
' This Sub has the Run-time error '1004': Method 'AddCustomList' of object'_Application' failed on line "Application.AddCustomList ListArray:=sortOrder".
' To try and cure it I passed the values of the sortOrder range to Application.AddCustomList, .Value to reference the values rather than the range itself _
but I can not cure the run-time error.
Dim ws As Worksheet
Dim dataRange As Range
Dim cell As Range
Dim firstCell As Range
Dim lastCell As Range
Dim sortCriteria As Range
Dim sortOrder As Range
Dim i As Integer
' Set worksheet
Set ws = ThisWorkbook.Worksheets("Example")
' Find the last used row in Column B
Set dataRange = ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
For Each cell In dataRange
If Not IsEmpty(cell) Then
If firstCell Is Nothing Then
Set firstCell = cell
Else
Set lastCell = cell
' Define the range to be sorted
Set sortCriteria = ws.Range(ws.Cells(firstCell.Row, 1), ws.Cells(lastCell.Row, 2))
' Sort the range according to criteria in the virtual table
' I added .Value to pass the values instead of the range to try and _
cure the run-time error but with no success.
Application.AddCustomList ListArray:=sortOrder.Value
sortCriteria.Sort key1:=ws.Cells(1, 1), order1:=xlAscending, Header:=xlNo
' Move the sorted values up starting on the row adjacent to the first cell in column A that is not blank
For i = 1 To lastCell.Row - firstCell.Row
ws.Rows(firstCell.Row + i).Cut
ws.Rows(firstCell.Row - 1).Insert Shift:=xlDown
Next i
' Reset firstCell and lastCell for the next range
Set firstCell = Nothing
Set lastCell = Nothing
End If
End If
Next cell
End Sub


4. This sub is more for convience as, when evoked, it refreshes the test data back to its original state in the "Example" worksheet after any testing.

Sub TestDataRefresh()
Dim LastRowDataRefresh As Long
Dim LastRowExample As Long
Worksheets("Example").Activate
LastRowDataRefresh = Worksheets("DataRefresh").Cells(Rows.Count, 1).End(xlUp).Row
LastRowExample = Worksheets("Example").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("DataRefresh").Range("A2:C" & LastRowDataRefresh).Copy
Worksheets("Example").Range("A2").PasteSpecial Paste:=xlPasteValues
Range("A2").Select
End Sub

Paul_Hossler
07-18-2024, 06:32 PM
I tried to use mostly the built in functions




Option Explicit

Sub Try_1()
Dim rDataIn As Range, rData As Range, rData1 As Range
Dim sTempName As String
Dim r As Long
Application.ScreenUpdating = False
' get a temp worksheet name
sTempName = Format(Now, "hhmmssnn")
' save input data
Set rDataIn = ActiveSheet.Cells(1, 1).CurrentRegion
'delete temp ws if it exists (unlikely)
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(sTempName).Delete
Application.DisplayAlerts = True
On Error GoTo 0
' add a temp ws
Worksheets.Add.Name = sTempName
' copy input cells into simgle cell on temp ws
With rDataIn
For r = 1 To .Rows.Count
Worksheets(sTempName).Cells(r, 1).Value = .Cells(r, 1).Value & vbTab & .Cells(r, 2).Value
Next r
End With
With Worksheets(sTempName)
Set rData = .Cells(1, 1).CurrentRegion
Set rData1 = rData.Cells(2, 1).Resize(rData.Rows.Count, rData.Columns.Count)
' remove the dups
rData.RemoveDuplicates Columns:=1, Header:=xlYes
' sort the temp ws data
With .Sort
.SortFields.Clear
.SortFields.Add Key:=rData1, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'split temp data at the join
.Cells(1, 1).CurrentRegion.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
' clear orig dat
rDataIn.Clear
' put temp data back
.Cells(1, 1).CurrentRegion.Copy rDataIn
End With
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(sTempName).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

Event2020
07-19-2024, 01:37 PM
I tried to use mostly the built in functions



Hi Paul.

Thank you for kindly taking the time to write this code.

I will give it a try over the weekend.

Much appreciated.