Delete Range With Condition

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

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!

Code:

---

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

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

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

Quote:

---

Originally Posted by stapuff

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:

Quote:

---

Originally Posted by stapuff

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.

Matt -

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

from

Code:

---

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

---

to

Code:

---

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

---

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

Kurt

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