Delete Range With Condition

[stapuff]

Column A is Part#
Column B is Whse
Column C is $
Column D is %

An example of my data is

AAA000 10 .3206 33%
AAA000 15 .3209 95%
AAA000 18 .33 47%
BBB000 10 .69 89%
BBB000 12 .71 100%
BBB000 21 .71 67%

what I would like to do is have a macro go down the range and delete (by part #) if all of the occurances of part's % >51%.

In the example above none of part # AAA000 would not be deleted because the 3rd occurance <51% , but all of BBB000 would be because all 3 meet the condition.

The part # can be listed up to 25 times but they would all be consecutive.

Range is from A2-D5000

Any help or idea's would be greatly appreciated.

Thanks,

Kurt

[mvidas]

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

[stapuff]

mvidas -

Outstanding! :clap: This works extremely fast:bug: ! It's done before I can get my finger off the command button.:)

Thanks for your time and efforts. I really appreciate it.

Kurt

[mvidas]

Glad to help, let me know if it needs any tweaking!
Matt

[mvidas]

Matt -

I need a little more help with

http://www.vbaexpress.com/forum/showthread.php?t=2933

I had to add a column :( so A-E (which I have already done) but how I populate A-E has changed.

Was a simple paste now change to pastespecial.xlpastevalue which change my simple 78% to 77.9527559055118%. The macro is now freaking :bug: out. Damn near deleteing the entire range.

Based of what you said below, I am not sure :dunno how to convert the macro or the value.

Any help would be greatly appreciate:bow: : pray2: .

Thanks,

Stapuff

'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

I just got this PM from you, and as it is related to this question I figured I'd keep it here. What is the new column breakdown, like you had originally:

Column A is Part#
Column B is Whse
Column C is $
Column D is %

Also, I'm assuming your percentage column is now reading as 51% instead of .51 with a percentage number format. If this is the case, change the 0.51 to 51 and that should help out a bit.

[stapuff]

Matt -

When one add's a column one MUST change the column reference

from

If AllValues(i, 4) < PercLimit Then UniqArr(j) = ""

to

If AllValues(i, 5) < PercLimit Then UniqArr(j) = ""

Thanks for your help and I apologize for wasting your's and the boards time.

Kurt

[mvidas]

You didn't waste anyone's time. Was that the problem, the percentage column just got moved?
You may want to create variables denoting the important columns, then just change it at the top if you need to. Let me know if you need any help with that!
Matt