How to sum and remove duplicates on 2 columns - excel

Application Match for one column works but for 2 columns is giving me error
With Sht
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
For i = LastRow To 2 Step -1
DupRow = Application.Match(Cells(i, 9).Value, Range(Cells(1, 9), Cells(i - 1, 9)), 0)
DoEvents
If Not IsError(DupRow) Then
Cells(i, 8).Value = Cells(i, 8).Value + Cells(DupRow, 8).Value
Cells(i, 9).Value = Cells(i, 9).Value + Cells(DupRow, 9).Value
Rows(DupRow).Delete
End If
Next i
End With
for 2 columns Error runtime 1004
DupRow = Application.Match(Cells(i, 4).Value & Cells(i, 5).Value, Range(Cells(1, 4) & Cells(1, 5), Cells(i - 1, 4) & Cells(i - 1, 5)), 0)
What is the correct way of doing this?

In my opinion it's better to use dictionary for that, which has built-in method for managing keys, so it can be used to get unique values:
Sub teest()
Dim val As String
Set dict = CreateObject("Scripting.Dictionary")
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
val = Cells(i, 1).Value & Cells(i, 2).Value
If dict.Exists(val) Then
Rows(i).Delete
Else
dict.Add val, 0
End If
Next
End Sub

Related

copy and paste as negative value

I have developed below code and i want that it should paste the value as negative instead of positive value. I looked around but nothing similar found.
It should be negative ws.Cells(r, "I").Value
Sub copyandpasteasnegative()
Dim ws As Worksheet, LastRow As Long, r As Long
Set ws = Sheet1
LastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For r = 2 To LastRow
If ws.Cells(r, "B") = "KIO" Then
ws.Cells(r, "I").Value = ws.Cells(r + 1, "I").Value
End If
Next
End Sub
Simple multiplication:
ws.Cells(r, "I").Value = -1 * ws.Cells(r + 1, "I").Value
Probably best to use IsNumeric before attempting to multiply:
With ws.Cells(r + 1, "I")
If IsNumeric(.Value) Then
ws.Cells(r, "I").Value = .Value * -1
End If
End With
I think you can do this by changing only one line. Try this:
ws.Cells(r, "I").Value = 0 - ws.Cells(r + 1, "I").Value

Populate listbox with headers

I am trying to populate a listbox from a list of items, I can get it to populate but it is taking in my header row as a row in the list and the headers are blank. I am not sure where I am going wrong. Any help would be great.
Sub populateList()
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Set ws = Worksheets("ProjectData")
lbTasks.Clear
lbTasks.ColumnHeads = True
lbTasks.ColumnCount = 10
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
If ws.Cells(i, 1).Value <> vbNullString Then lbTasks.AddItem ws.Cells(i, 1).Value
If ws.Cells(i, 2).Value <> vbNullString Then lbTasks.List(i - 1, 1) = ws.Cells(i, 2).Value
If ws.Cells(i, 3).Value <> vbNullString Then lbTasks.List(i - 1, 2) = ws.Cells(i, 3).Value
If ws.Cells(i, 4).Value <> vbNullString Then lbTasks.List(i - 1, 3) = ws.Cells(i, 4).Value
If ws.Cells(i, 5).Value <> vbNullString Then lbTasks.List(i - 1, 4) = ws.Cells(i, 5).Value
If ws.Cells(i, 6).Value <> vbNullString Then lbTasks.List(i - 1, 5) = ws.Cells(i, 6).Value
If ws.Cells(i, 7).Value <> vbNullString Then lbTasks.List(i - 1, 6) = ws.Cells(i, 7).Value
If ws.Cells(i, 8).Value <> vbNullString Then lbTasks.List(i - 1, 7) = ws.Cells(i, 8).Value
If ws.Cells(i, 9).Value <> vbNullString Then lbTasks.List(i - 1, 8) = ws.Cells(i, 9).Value
If ws.Cells(i, 10).Value <> vbNullString Then lbTasks.List(i - 1, 9) = ws.Cells(i, 10).Value
Next i
End Sub

Running a loop only if the value in column 16 of the active sheet is > 0

This is my first experience writing any kind of code. I have been building a tracking system for my work in Excel. I have everything that I want currently working except I have a user form that when you click the command button it will look at my current inventory table (the table has a column (16 or P) that list how many cases of a product we should order to get us to our target stock quantity) and return a list of products and what we need to order. I have the form so it works, It populates a list box on the form with all the info that I want, but I would like it to exclude any rows that the table says we don't need to order. Here is my current code.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim i As Integer
Set ws = Worksheets("Current")
lstProd.Clear
lstProd.ColumnCount = 9
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
lstProd.AddItem ws.Cells(i, 1).Value
lstProd.List(i - 1, 1) = ws.Cells(i, 2).Value
lstProd.List(i - 1, 2) = ws.Cells(i, 3).Value
lstProd.List(i - 1, 3) = "$" & Format(ws.Cells(i, 4).Value, "0.00")
lstProd.List(i - 1, 4) = ws.Cells(i, 5).Value
lstProd.List(i - 1, 5) = ws.Cells(i, 6).Value
lstProd.List(i - 1, 6) = ws.Cells(i, 9).Value
lstProd.List(i - 1, 7) = ws.Cells(i, 14).Value
lstProd.List(i - 1, 8) = ws.Cells(i, 16).Value
Next i
End Sub
I have tried a lot of if ws.cells(i, 16) = "0" and For ws.cells..... but always end up with different errors. I know it is something simple that I am missing but it has just eluded me so I thought I would break down and ask for help.
If "the table says we don't need to order" means there is an empty cell in the checked range you may use the next code:
For i = 1 To LastRow
If ws.Cells(i, 1).Value <> "" Then
lstProd.AddItem ws.Cells(i, 1).Value
lstProd.List(i - 1, 1) = ws.Cells(i, 2).Value
lstProd.List(i - 1, 2) = ws.Cells(i, 3).Value
lstProd.List(i - 1, 3) = "$" & Format(ws.Cells(i, 4).Value, "0.00")
lstProd.List(i - 1, 4) = ws.Cells(i, 5).Value
lstProd.List(i - 1, 5) = ws.Cells(i, 6).Value
lstProd.List(i - 1, 6) = ws.Cells(i, 9).Value
lstProd.List(i - 1, 7) = ws.Cells(i, 14).Value
lstProd.List(i - 1, 8) = ws.Cells(i, 16).Value
End if
Next i
If not, you must describe how those cells look/contain in order to make you understand "we don't need to order"...

after "on error goto" errorhandler, how do I resume to desired code line instead of resume next

How do I resume to my desired code line instead of resume next.
Let's say I want to resume back to:
cells(i,1),value = Mid(cells(i,1).value,16,Len(cells(i,1))-16)
How would you code it?
Thanks !!
Sub testing()
Dim i As Integer
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow - 1
Cells(i, 1).Value = Mid(Cells(i, 1).Value, 16, Len(Cells(i, 1)) - 16)
On Error GoTo errhandler_2
Cells(i, 2).Value = Left(Cells(i, 2), Len(Cells(i, 2)) - 1)
Cells(i, 3).Value = Left(Cells(i, 3), Len(Cells(i, 3)) - 1)
Cells(i, 4).Value = Left(Cells(i, 4), Len(Cells(i, 4)) - 1)
Next
errhandler_2: Cells(i, 2).Value = "#NA"
errhandler_3: Cells(i, 3).Value = "#NA"
errhandler_4: Cells(i, 4).Value = "#NA"
Resume Next
End Sub
Sub testing()
Dim i As Integer
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
letsdothis:
Cells(i, 1).Value = Mid(Cells(i, 1).Value, 16, Len(Cells(i, 1)) - 16)
On Error GoTo errhandler
Cells(i, 2).Value = Left(Cells(i, 2), Len(Cells(i, 2)) - 1)
Cells(i, 3).Value = Left(Cells(i, 3), Len(Cells(i, 3)) - 1)
Cells(i, 4).Value = Left(Cells(i, 4), Len(Cells(i, 4)) - 1)
Next
Exit Sub
errhandler: Cells(i, 2).Value = "#NA"
Cells(i, 3).Value = "#NA"
Cells(i, 4).Value = "#NA"
i = i + 1 'TO PREVENT TRAP IN THE LOOP
Resume letsdothis:
End Sub

VBA macro to merge duplicate rows based on multiple values in a row

I have a sample MS Excel table:
I am trying to write a VBA macro that would allow me to compare rows, the comparison is done using multiple cells(A2:E2), and the rest of the cells(F2:I2) would merge its values without comparison. I would like to be able to compare one row - cells(A2:E2) to cells(A3:E3), then cells(A2:E2) to cells(A4:E4)... when it is done comparing it would merge the duplicates - so that cells(Fx:Ix) would merge as well.
The final effect would look like this:
So far I have came up with this code, but running it crashes Excel. Any kind of advice would be much appreciated.
Thanks in advance
Sub MergeDuplicateRows()
Dim i As Long
Dim j As Long
Dim RowCount As Long
Dim sameRows As Boolean
sameRows = True
RowCount = Rows.Count
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = 1 To Range("B" & RowCount).End(xlUp).Row
For j = 1 To 5
If StrComp(Cells(i, j), Cells(i + 1, j), vbTextCompare) Then
sameRows = False
End If
Next j
If sameRows Then
Range(Cells(i, 1), Cells(i + 1, 1)).Merge
Range(Cells(i, 2), Cells(i + 1, 2)).Merge
Range(Cells(i, 3), Cells(i + 1, 3)).Merge
Range(Cells(i, 4), Cells(i + 1, 4)).Merge
Range(Cells(i, 5), Cells(i + 1, 5)).Merge
Range(Cells(i, 6), Cells(i + 1, 6)).Merge
Range(Cells(i, 7), Cells(i + 1, 7)).Merge
Range(Cells(i, 8), Cells(i + 1, 8)).Merge
Range(Cells(i, 9), Cells(i + 1, 9)).Merge
End If
sameRows = True
Next i
Application.DisplayAlerts = True
End Sub
Give this a shot - I had to change around some logic, change your For loop to a Do While loop, and instead of merging we're just deleting rows instead. I tested this on your sample data and it worked alright, I'm not sure how it will perform on 1500 rows, though:
Sub MergeDuplicateRows()
Dim i As Long
Dim j As Long
Dim sameRows As Boolean
Application.DisplayAlerts = False
Application.ScreenUpdating = False
i = 2
Do While Cells(i, 2).Value <> ""
For j = 1 To 5
If Cells(i, j).Value <> Cells(i + 1, j).Value Then
sameRows = False
Exit For
Else
sameRows = True
End If
Next j
If sameRows Then
If Cells(i, 6).Value = "" Then Cells(i, 6).Value = Cells(i + 1, 6).Value
If Cells(i, 7).Value = "" Then Cells(i, 7).Value = Cells(i + 1, 7).Value
If Cells(i, 8).Value = "" Then Cells(i, 8).Value = Cells(i + 1, 8).Value
If Cells(i, 9).Value = "" Then Cells(i, 9).Value = Cells(i + 1, 9).Value
Rows(i + 1).Delete
i = i - 1
End If
sameRows = False
i = i + 1
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Resources