Deleting Similar Rows using Excel VBA - excel

I am trying to write a VBA code for an Excel macro so that I can manually trigger the macro to do the following:
In the event that any two rows have:
Same value in column A
Same value in Column B
"apple" in Column C
Same value in Column D
Then I would like all of those rows to be deleted except the row with the highest value in column E.
As an example, if:
cell A1 = cell A2
cell B1 = cell B2
cell C1 and Cell C2 = "apple"
cell D1 = cell D2
Cell E1 = 5 and Cell E2 = 10
Then Row 1 gets deleted and Row 2 remains.
The overall goal is to delete similar rows.
Per a user's suggestions, this process can be aided/simplified by sorting range by c="apple",a,b,d so that rows can be analyzed consecutively.
Example of Code Outcome
I put together the following code, but I am unfamiliar with the delete row aspect and how to incorporate the highest value, but this was my best shot. The If and elseif statements are questionable.
Sub Macro()
Dim a As Range
Dim b As Range
Dim c As Range
Dim d As Range
Dim e As Range
For Each a In Range("A1:A9999")
For Each b In Range("B1:B9999")
For Each c In Range("C1:C9999")
For Each d In Range("D1:D9999")
For Each e In Range("E1:E9999")
If a.Offset(-1, 0) = a And b.Offset(-1, 0) And c.Offset(-1, 0) = c And d.Offset(-1, 0) = d And e.Offset(-1, 0) < e Then Range(a).EntireRow.Delete
ElseIf a.Offset(-1, 0) = a And b.Offset(-1, 0) And c.Offset(-1, 0) = c And d.Offset(-1, 0) = d And e.Offset(-1, 0) > e Then Range(a.Offset(-1, 0)).EntireRow.Delete
Exit For
Next a
Next b
Next c
Next d
Next e
End Sub

I hope it works.
Option Explicit
Sub RunMacro()
Dim i As Long, LastRow As Long, j As Long
Dim cellA, cellB, cellC, cellD, cellE
Dim Rng As Range
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
cellA = Range("A" & i).Value
cellB = Range("B" & i).Value
cellC = Range("C" & i).Value
cellD = Range("D" & i).Value
cellE = Range("E" & i).Value
For j = LastRow To 2 Step -1
If Range("A" & j).Value = cellA And Range("B" & j).Value = cellB Then
If Range("C" & j).Value = cellC And Range("D" & j).Value = cellD Then
If cellE > Range("E" & j).Value Then
Range("E" & j).EntireRow.Delete
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
End If
End If
End If
Next j
Next i
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
With ActiveSheet
Set Rng = Range("A1", Range("E1").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
End With
End Sub

Related

Copy ranges and multiply in loop

Ive been searching left and right but seem to only find bits and pieces. i'm unable to combine these into the solution i need.
My workbook has a list of items on the first sheet, the partnumbers in column A have to be searched for in Column A of a second sheet and if they exist there, those rows need to be copied to a third sheet.In steps i'm looking to do the following:
Column A of sheet1 (called "input") has several partnumbers.
After clicking CommandButton2 on sheet1, all partnumbers in Column A (starting in cell A5)should be searched for in Column A of sheet3 (called "partlists", starting in A2).
If found here, for all the respective rows where the partnumbers match: columns C to G("partlists") should be copied to sheet2("picklist") column A below the last row, the value in column E("picklist") has to be multiplied with the value in Column E("input") AND columns G to K("input") copied to the respective rows column G("Picklist")
If not found on "partlists", copy entire row from "input" to "picklist" below last row.
So far i've got the following code:
Sub InputPickMatch()
Dim LR As Long, i As Long, lngNextRow As Long, LookUpListInput As Range, LookUpListParts As Range
Set LookUpListInput = Sheets("Input").Range("A:A") 'lookup list Input
Set LookUpListParts = Sheets("Partlists").Range("A:A")
With Sheets("Input")
LR = .Cells(Rows.Count, "A").End(xlUp).Row 'last row
For i = 5 To LR
If IsError(Application.Match(.Cells(i, "A").Value, LookUpListParts, 0)) Then
.Range(Cells(i, "A").Address(), Cells(i, "D").Address()).Copy
Sheets("Picklist").Select
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range("A" & lngNextRow).PasteSpecial _
Paste:=xlPasteValues
.Range(Cells(i, "F").Address(), Cells(i, "K").Address()).Copy
Sheets("Picklist").Range("E" & lngNextRow).PasteSpecial _
Paste:=xlPasteValues
End If
Next i
End With
With Sheets("Partlists")
LR = .Cells(Rows.Count, "A").End(xlUp).Row 'last row
For i = 3 To LR
If IsNumeric(Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)) Then
.Range(Cells(i, "C").Address(), Cells(i, "G").Address()).Copy
Sheets("Picklist").Select
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range("A" & lngNextRow).PasteSpecial _
Paste:=xlPasteValues
'Sheets("Picklist").Cells(lngNextRow, "E") = Sheets("Input").Cells(LookUpListInput, "E") * .Cells(i, "G") 'NOT WORKING: Multiply row from lookuplist column E with .Cells(i, "G")
'Sheets("Input").Range(Cells(LookUpList, "G").Address(), Cells(LookUpListInput, "K").Address()).Copy 'NOT WORKING: Copy row from lookuplist column G:K
'Sheets("Picklist").Range("F" & lngNextRow).PasteSpecial 'Paste Picklist column G
End If
Next i
End With
End Sub
It's working ok up to where i try to multiply and copy from the lookup list.
Hopefully someone can help
I got it guys
Sub InputToPicklist()
Dim LR As Long, i As Long, lngNextRow As Long, LookUpListInput As Range, LookUpListParts As Range
Dim Matchres As Variant
Set LookUpListInput = Sheets("Input").Range("A:A")
Set LookUpListParts = Sheets("Partlists").Range("A:A")
With Sheets("Input")
LR = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 5 To LR
If IsError(Application.Match(.Cells(i, "A").Value, LookUpListParts, 0)) Then
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range(Cells(lngNextRow, "A").Address(), Cells(lngNextRow, "D").Address()).Value = .Range(Cells(i, "A").Address(), Cells(i, "D").Address()).Value
Sheets("Picklist").Range(Cells(lngNextRow, "E").Address(), Cells(lngNextRow, "J").Address()).Value = .Range(Cells(i, "F").Address(), Cells(i, "K").Address()).Value
End If
Next i
End With
With Sheets("Partlists")
LR = .Cells(Rows.Count, "A").End(xlUp).Row 'last row
For i = 3 To LR
If IsNumeric(Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)) Then
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range(Cells(lngNextRow, "A").Address(), Cells(lngNextRow, "E").Address()).Value = .Range(Cells(i, "C").Address(), Cells(i, "G").Address()).Value
Matchres = Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)
Sheets("Picklist").Cells(lngNextRow, "E") = Sheets("Input").Cells(Matchres, "F") * .Cells(i, "G") 'Multiply row from lookuplist column E with .Cells(i, "G")
Sheets("Picklist").Range(Cells(lngNextRow, "F").Address(), Cells(lngNextRow, "J").Address()).Value = Sheets("Input").Range(Cells(Matchres, "G").Address(), Cells(Matchres, "K").Address()).Value 'Copy row from lookuplist column G:K
End If
Next i
End With
Sheets("Input").Range("A5:K138").ClearContents
End Sub
First
Dim Matchres As Variant
and calling it
Matchres = Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)
Does the trick

Microsoft Excel VBA Scripting: Recursive column matching

Sub NewMacro()
Dim endRow As Long
endRow = Sheet1.Range("A999999").End(xlUp).Row
For i = 1 To endRow
If Sheet1.Range("A" & i).Value = Sheet1.Range("F" & i).Value Then
Sheet1.Range("K" & i).Value = "Yes" Else
Sheet1.Range("K" & i).Value = "No"
End If
Next i
End Sub
This will compare column A with column F and displays the result in column K.
What I need is if this value is true, then like the above it should compare column B with column G, column C with column H and so on......and should display the results in next column. Please help.
I think you need a loop on the columns:
Sub NewMacro()
Dim endRow As Long
Dim i As Long
Dim c As Long
With Sheet1
endRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To endRow
For c = 1 To 5
If .Cells(i, c).Value = .Cells(i, c + 5).Value Then
.Cells(i, c + 10).Value = "Yes"
Else
.Cells(i, c + 10).Value = "No"
End If
Next c
Next i
End With
End Sub
This compares column A with F, column B with G, column C with H, column D with I and column E with J. Results are placed in columns K, L, M, N and O respectively.
This is equivalent to using the formula =IF(A1=F1,"Yes","No") in cell K1 and copying it across and down.
And a version which will update columns with "Yes", but stop as soon as it reaches a "No":
Sub NewMacro()
Dim endRow As Long
Dim i As Long
Dim c As Long
With Sheet1
endRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To endRow
For c = 1 To 5
If .Cells(i, c).Value = .Cells(i, c + 5).Value Then
.Cells(i, c + 10).Value = "Yes"
Else
.Cells(i, c + 10).Value = "No"
Exit For
End If
Next c
Next i
End With
End Sub

Transpose sections of an Excel column

I have 8000 rows of data in column A.
I am trying to write code that would scan the rows and each time there's a cell formatted as bold, to determine a range that includes that cell and all cells in the subsequent rows until the next bold cell. This range should be copied to column B, tranposed.
Here's the code that I have so far:
Sub Sorting()
Application.ScreenUpdating = False
last_row = ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Row
y = 1
For i = 1 To LastRow
If Range("A" & i).Font.Bold = True Then
Range("A" & i).Copy Range("A" & i + 9)
Range("B" & y).PasteSpecial Transpose:=True
y = y + 1
x = i
Else
Range("A" & x).Copy Range("B" & i)
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub doIt()
Dim a1 As Range: Set a1 = Range("A1")
Dim a2 As Range: Set a2 = a1.Offset(1)
Dim b As Range: Set b = Range("B1")
Do Until Intersect(a2, ActiveSheet.UsedRange) Is Nothing
If a2.Font.Bold Then
b.Resize(, a2.row - a1.row) = Application.Transpose(Range(a1, a2.Offset(-1)))
Set a1 = a2: Set a2 = a1.Offset(1): Set b = b.Offset(1)
Else
Set a2 = a2.Offset(1)
End If
Loop
b.Resize(, a2.row - a1.row) = Application.Transpose(Range(a1, a2.Offset(-1)))
End Sub

Unable to get the match property of the WorkSheet function class - Syntax?

I keep getting this error on the line with Application.WorksheetFunction and from reading on the topic for hours I feel that I've gotten just about nowhere.
Does it have something to do with the way I'm referencing Sheet2? Or am I not understanding fully what Application.WorksheetFunction is supposed to do?
Sub SearchForValues()
i = 4 'starts the iterator at column D
Do While Cells(1, i) <> ""
Dim l As Long, searchRange As String
n = 2
Do While Range("A" & n) <> "" 'loop until the last row of data in the first column
StartRow = Range("B" & n)
EndRow = Range("C" & n)
searchRange = "A" & StartRow & ":Q" & EndRow
l = Application.WorksheetFunction.Match(Cells(1, i), Worksheets("Sheet2").Range(searchRange), 0)
Range("D" & n) = l
n = n + 1
Loop
i = i + 1
Loop
End Sub
Here's a screenshot of the data I have. Columns B and C are the ranges of rows that I want to search in on Sheet2 for each row on sheet 1 and each cell across the top is a term I want to search for in that range.
Scott Craner already answered your question in his comments with "
Match only works on 1 dimensional arrays; either one row or one column" and "Use the VBA Find()".
Here is an example of how you can use Range.Find
Sub SearchForValues()
Application.ScreenUpdating = False
Dim Target As Range
Dim x As Long, y As Long
With Worksheets("Sheet1")
For x = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
For y = 4 To .Cells(1, .Columns.Count).End(xlToLeft).Column
Set Target = Worksheets("Sheet2").Range("A" & .Cells(x, "B").Value & ":Q" & .Cells(x, "C").Value)
.Cells(x, y).Value = Not Target.Find(.Cells(1, y).Value) Is Nothing
Next
Next
End With
Application.ScreenUpdating = True
End Sub

Delete rows if multiple cells have zero

I have multiple Excel workbooks that contain about 8,000 rows so it would be nice to use a macro.
Basically, if any row has a zero (0) in all columns (at the same time) B, D, E, I, J, and K it will delete.
Here is what I have so far...way too new with VB to figure out.
Sub DeleteRowsZeros()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
If (Range("B") = "0" And Range("D" & i) = "0" And Range("E" & i) = "0" And Range("I" & i) = "0" _
And Range("J" & i) = "0" And Range("K" & i) = "0") Then Rows(i).Delete
Next i
End Sub
Try this :
Sub DeleteRowsZeros()
Dim cell As Range, notZeroColumns As Range, row As Range
Set row = Range("A" & Rows.Count).End(xlUp).EntireRow.Offset(1, 0)
Set notZeroColumns = Range("B:B,D:E,I:k")
While row.row <> 1
Set row = row.Offset(-1, 0)
For Each cell In Intersect(row, notZeroColumns)
If cell.Text <> "0" Then GoTo continueLbl
Next
row.Offset(1, 0).Delete
continueLbl:
Wend
End Sub
EDIT : bugfixe

Resources