Need VBA code that will delete rows with certain parameters

PaigeWarner

New Member
Joined
May 27, 2020
Messages
44
Office Version
  1. 365
Platform
  1. MacOS
I need VBA coding that will delete rows based on the following Parameters:

ONLY looking at three columns together: Material Number (column J), Old Price (column M) and New Price (column N) and if duplicates, delete extra duplicate rows.

Here is a screen shot of how the file starts out:
1615994075906.png


And here is a screen shot of how it should end up (the rows that should be left after parameters above):
1615994256470.png


Here is a copy and paste of the rows and columns:
IDoc numberPartner numberVendor NamePurchasing DocumentItemMaterial TypeGen. item cat. grpMtrl Stock StatusMaterial CategoryMaterial NumberMIC NumberMaterial DescriptionOld PriceNew Price% PriceVarianceStatus message
79988937511121GHI Incorporated470399662711HAWAZNORStock02110104D567H2Grill Cleaner25.7026.462.96ME730
79988937111121GHI Incorporated47039966265HAWAZNORStock02110104D567H3Grill Cleaner25.7027.462.96ME730
79988857211121GHI Incorporated47039966241HAWAZNORStock02110104D567H4Grill Cleaner25.7026.462.96ME728
79988937711121GHI Incorporated51039966222HAWAZNORStock02110104D567H5Grill Cleaner25.7026.462.96ME730
79992539531415JKL Incorporated470399643121HAWAZNORStock14119219J1313RNIce Bucket8.839.062.60ME730
79992275831415JKL Incorporated470399643022HAWAZNORStock14119219J1313RNIce Bucket8.839.062.60ME730
79967931531415JKL Incorporated47039964278HAWAZNORStock14119219J1313RNIce Bucket8.839.062.60ME730
79975258931415JKL Incorporated470399642422HAWAZNORStock14119219J1313RNIce Bucket8.839.062.60ME728
79992539931415JKL Incorporated51039964218HAWAZNORStock14119219J1313RNIce Bucket8.839.062.60ME730
79964883216171MNO Incorporated47039960463HAWAZNORStock1413714827YH3RLandry Detergent117.64135.7015.35ME730
79964883216171MNO Incorporated47039960465ZSPCZNORStock1413715328YH3RWater Tank180.83207.4414.72ME730
79964883216171MNO Incorporated300399604611ZSPCZNORStock1413716529YH3RFloor Cleaner113.88141.3424.11ME730
79964883216171MNO Incorporated470399604612HAWAZNORStock1413716830YH3RBlender208.01222.206.82ME730
79964883216171MNO Incorporated47039960462HAWAZNORStock1413717726YH3RDish Soap101.84109.487.50ME790
80001892867891DEF Incorporated47039965901ZSPCZBN3Non Stock24443217H2312PFaucet Handle38.3440.254.98ME730


Thank you in advance for any assistance you can provide!
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
348
Office Version
  1. 365
Platform
  1. Windows
It was hard to write a code for this than I initially thought...
The code below only checks column J to see if there're duplicates in it but does get you the result you need.
VBA Code:
Sub DeleteRowsWithDuplicateMaterialNumber()

    'Get all material numbers
    Dim d As Object, lr As Long, i As Long
    Set d = CreateObject("Scripting.Dictionary")
    lr = Range("J" & Rows.Count).End(xlUp).Row
  
    For i = 2 To lr
        d.Item(Cells(i, "J").Value) = 1
    Next i
  
    'Get duplicate material numbers
    Dim dupVals() As String, j As Long
  
    For i = 0 To d.Count - 1
        If WorksheetFunction.CountIf(Cells(2, "J").Resize(lr - 2), d.keys()(i)) > 1 Then
            ReDim Preserve dupVals(j)
            dupVals(j) = d.keys()(i)
            j = j + 1
        End If
    Next i
  
    'Get row numbers with duplicates
    Dim rng As Range, tempRng As Range, rowsToDelete() As String
  
    j = 0
    For i = LBound(dupVals) To UBound(dupVals)
        Set rng = Range("J:J").Find(What:=dupVals(i), LookAt:=xlWhole)
        Set tempRng = rng
        Do While Not rng Is Nothing
            If rng.Address <> tempRng.Address Then
                ReDim Preserve rowsToDelete(j)
                rowsToDelete(j) = rng.Row
                j = j + 1
            End If
            Set rng = Range("J:J").FindNext(rng)
            If rng.Address = tempRng.Address Then Exit Do
        Loop
    Next i
  
    'Delete rows with duplicates
    Application.ScreenUpdating = False
    For i = UBound(rowsToDelete) To LBound(rowsToDelete) Step -1
        Rows(rowsToDelete(i)).Delete
    Next i
    Application.ScreenUpdating = True
  
End Sub
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
58,153
Office Version
  1. 365
Platform
  1. Windows
@kanadaaa The OP is using a Mac, so cannot use the Scripting.Dictionary. ;)
 

PaigeWarner

New Member
Joined
May 27, 2020
Messages
44
Office Version
  1. 365
Platform
  1. MacOS

ADVERTISEMENT

Thank you so much!
 

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
348
Office Version
  1. 365
Platform
  1. Windows
For Mac OS, without Scripting.Dictionary
VBA Code:
Sub DeleteRowsWithDuplicateMaterialNumber() 'MacVer

    'Get all material numbers
    Dim lr As Long, i As Long, mNums() As Long, j As Long
    lr = Range("J" & Rows.Count).End(xlUp).Row

    For i = 2 To lr
        If IsInArray(Cells(i, "J").Value, mNums) = False Then
            ReDim Preserve mNums(j)
            mNums(j) = Cells(i, "J").Value
            j = j + 1
        End If
    Next i
    
    'Get duplicate material numbers
    Dim dupVals() As String
    
    j = 0
    For i = LBound(mNums) To UBound(mNums)
        If WorksheetFunction.CountIf(Cells(2, "J").Resize(lr - 2), mNums(i)) > 1 Then
            ReDim Preserve dupVals(j)
            dupVals(j) = mNums(i)
            j = j + 1
        End If
    Next i
    
    'Get row numbers with duplicates
    Dim rng As Range, tempRng As Range, rowsToDelete() As String
    
    j = 0
    For i = LBound(dupVals) To UBound(dupVals)
        Set rng = Range("J:J").Find(What:=dupVals(i), LookAt:=xlWhole)
        Set tempRng = rng
        Do While Not rng Is Nothing
            If rng.Address <> tempRng.Address Then
                ReDim Preserve rowsToDelete(j)
                rowsToDelete(j) = rng.Row
                j = j + 1
            End If
            Set rng = Range("J:J").FindNext(rng)
            If rng.Address = tempRng.Address Then Exit Do
        Loop
    Next i
    
    'Delete rows with duplicates
    Application.ScreenUpdating = False
    For i = UBound(rowsToDelete) To LBound(rowsToDelete) Step -1
        Rows(rowsToDelete(i)).Delete
    Next i
    Application.ScreenUpdating = True
    
End Sub

Function IsInArray(valToBeFound As String, arr As Variant) As Boolean
    Dim el As Variant
    
    On Error GoTo IsInArrayError: 'array is empty
    For Each el In arr
        If el = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next el
Exit Function
IsInArrayError:
    On Error GoTo 0
    IsInArray = False
    
End Function
 

PaigeWarner

New Member
Joined
May 27, 2020
Messages
44
Office Version
  1. 365
Platform
  1. MacOS
This specific code was for my work PC, so thank you again!
 

Watch MrExcel Video

Forum statistics

Threads
1,132,685
Messages
5,654,745
Members
418,149
Latest member
amamiche67

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top