Hi Kurt,
I have prepared a macro for you to do this, and have commented it explaining everything it does. If you have any questions or anything, please let me know!
Sub MergeLists()
Dim UniqArr() As String, i As Long, j As Long, ListCount As Long
Dim AllValues, PercLimit As Double
Dim TempRG As Range, DelRG As Range
'Fills an array variable with the unique Part#s
'Then checks the percentages for each part number, and if any percentage
'is less than 51% (controlled by a variable) then it removes that part #
'from the list. All remaining part #s will be searched in the spreadsheet,
'and the matching rows will be deleted.
'Enter minimum percentage for part numbers to be deleted if all percentages
'for that part are greater than or equal to this limit.
'Note: enter .51 for 51%, do not enter just 51 for this
PercLimit = 0.51
'Add used data in columns A:D (starting in row 2) to AllValues array
Set TempRG = Intersect(Range("A2:D65536"), ActiveSheet.UsedRange)
If TempRG Is Nothing Then Exit Sub
AllValues = TempRG.Value
'Initialize array counting variable
ListCount = 0
ReDim UniqArr(ListCount)
'Add unique names from column A
j = Range("A65536").End(xlUp).Row
If j > 1 Then
For i = 2 To j
If InStringArray(UniqArr, Range("A" & i).Text) = -1 Then
ReDim Preserve UniqArr(ListCount)
UniqArr(ListCount) = Range("A" & i).Text
ListCount = ListCount + 1
End If
Next i
End If
ListCount = ListCount - 1
'Remove any part#s that are less than the Percent Limit
For i = LBound(AllValues, 1) To UBound(AllValues, 1)
j = InStringArray(UniqArr, AllValues(i, 1))
If j > -1 Then
If AllValues(i, 4) < PercLimit Then UniqArr(j) = ""
End If
Next i
'Fill DelRG with the cells in column A that contain the part #s to be deleted
For i = 0 To ListCount
If UniqArr(i) <> "" Then
Set TempRG = FoundRange(Columns("A"), UniqArr(i))
If DelRG Is Nothing Then
Set DelRG = TempRG
Else
Set DelRG = Union(DelRG, TempRG)
End If
End If
Next i
'Delete DelRG's entire row, eliminating all the part #s with all parts greater
'than 51%
If Not DelRG Is Nothing Then
Application.ScreenUpdating = False
DelRG.EntireRow.Delete
Application.ScreenUpdating = True
End If
End Sub
Function InStringArray(ByRef vArray() As String, ByVal sValue As String) As Long
Dim i As Long
For i = LBound(vArray) To UBound(vArray)
If vArray(i) = sValue Then InStringArray = i: Exit Function
Next i
InStringArray = -1
End Function
Function FoundRange(ByVal vRG As Range, ByVal vVal) As Range
Dim FND As Range, FND1 As Range
Set FND = vRG.Find(vVal, LookIn:=xlValues, LookAt:=xlWhole)
If Not FND Is Nothing Then
Set FoundRange = FND: Set FND1 = FND: Set FND = vRG.FindNext(FND)
Do Until FND.Address = FND1.Address
Set FoundRange = Union(FoundRange, FND): Set FND = vRG.FindNext(FND)
Loop
End If
End Function
Matt
Reply With Quote
This works extremely fast
! It's done before I can get my finger off the command button.
Originally Posted by stapuff
so A-E (which I have already done) but how I populate A-E has changed.
how to convert the macro or the value.
.