Situation: I have data that I am trying to consolidate by summing rows based on the first column value (item ID number). If the ID numbers match I want the rows to be added together and the duplicate rows deleted.
I have written the following code and I am experiencing 2 issues: 1. The first time I run the code there is always a few duplicates left that were not consolidated 2. If I run the code again it sums and deletes rows even if they are not duplicates.
Any help would be much appreciated.
Sub ConsolidateRows()
Dim WB As Workbook
Dim WS As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim LastRow As Long
Dim LastCol As Long
Dim duplicate As String
Dim dupRow As Long
Dim cell As Range
Dim i As Integer
'set
Set WB = Workbooks("Book1")
Set WS = WB.Sheets("Data")
LastRow = WS.UsedRange.Rows.Count
LastCol = WS.UsedRange.Columns.Count
'Loop to consolidate, delete the duplicate rows
iRow = 1
While WS.Cells(iRow, 1).Value <> ""
duplicate = Cells(iRow, 1).Value
iRow = iRow + 1
For Each cell In WS.Range("A1:A" & LastRow).Cells
dupRow = cell.Row
If cell.Value = duplicate And iRow <> dupRow Then
For iCol = 3 To LastCol
Cells(iRow, iCol) = Application.WorksheetFunction.Sum(Cells(iRow, iCol), Cells(dupRow, iCol))
Next iCol
WS.Rows(dupRow).Delete
End If
Next cell
Wend
End Sub
When deleting rows, always start at the bottom and work your way up.
For example if Column A for rows 1-5 contain:
Alpha
Bravo
Charlie
Delta
Foxtrot
and you delete row 3, you now have
Alpha
Bravo
Delta
Foxtrot
Your loop counter (value 3) was pointing at Charlie before the deletion, but is now pointing at Delta, you then increment your counter to 4, and it's pointing at Foxtrot, therefore you never evaluated whether you needed to delete Delta.
Try this:
'Loop to consolidate, delete the duplicate rows
iRow = LastRow
While WS.Cells(iRow, 1).Value <> ""
duplicate = Cells(iRow, 1).Value
iRow = iRow - 1
For Each cell In WS.Range("A1:A" & LastRow -1).Cells
dupRow = cell.Row
If cell.Value = duplicate And iRow <> dupRow Then
For iCol = 3 To LastCol
Cells(iRow, iCol) = Application.WorksheetFunction.Sum(Cells(iRow, iCol), Cells(dupRow, iCol))
Next iCol
WS.Rows(dupRow).Delete
LastRow = LastRow - 1
End If
Next cell
Wend
*Note: code changes off the top of my head, you may have to make some minor additional tweaks to get it running backwards
Also, please investigate .Find() - it will make your code run significantly faster for finding dups.
Related
I have a problem with VBA as I'm trying to make a code that will first filter based on data on another tab and then in this filtered range it will look on one column all the values that appear twice (I need to have all these amounts marked with a color and not just the duplicate one).
So basically let's say that in Sheet2 I have in A column list of codes that I need to filter one by one on Sheet1 - A column.
Then based on this filtering I need to check in B column the values that appear twice and color those values with let's say green color (only on the visible cells).
Sub filter()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim xrow As Long, firstrow As Long, lastrow As Long
Dim SearchValue As Variant
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Set ws2 = wb.Sheets(2)
xrow = 2
Do
SearchValue = ws2.Cells(xrow, 1)
ws.Range("$A$1:$B$14").AutoFilter Field:=1, Criteria1:=SearchValue
With ws.AutoFilter.Range
firstrow = ws.Range("A" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Row
lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
'This is where the problem is
'how to match and make a color for each amount that appears twice in column B in this filtered range
End With
xrow = xrow + 1
Loop Until ws2.Cells(xrow, 1) = ""
End Sub
Edit: I ended up doing without filtering, this works for me in case anyone wonders:
xrow = 2
Do
SearchValue = ws2.Cells(xrow, 1)
lastrow = ws.UsedRange.Rows.Count
For x = 2 To lastrow
For y = x + 1 To lastrow
If ws.Cells(x, 1) = SearchValue And ws.Cells(y, 1) = SearchValue And ws.Cells(x, 2) = ws.Cells(y, 2) Then
ws.Cells(x, 2).Interior.Color = vbGreen
ws.Cells(y, 2).Interior.Color = vbGreen
Else
End If
Next y
Next x
xrow = xrow + 1
Loop Until ws2.Cells(xrow, 1) = ""
As a result the macro would check all codes for same values and I would have those marked with green color.
So if in Sheet1 in A column I have 2 exact same codes for example 1111 and those have the same value - 30 then this 30 would be marked with green in both lines but if the code 1111 has also value 25, this wouldn't be marked with a color.
I'm trying to merge cells in excel using VBA based on the column value. For instance, on row one, wherever the month is the same, merge those cells. I've tried the following code :
Sub Main()
Dim j As Long
For j = 1 To 13
If StrComp(Cells(1, j), Cells(1, j + 1), vbTextCompare) Then
Range(Cells(1, j), Cells(1, j + 1)).Merge
End If
Next j
End Sub
Here, I'm keeping the row fixed as the first row and iterating over the columns and checking if the next cell value is same as the current value. However, in the output it's merging incorrect cells. What am I missing here?
This is easier to understand.
Application.DisplayAlerts = False
With ThisWorkbook.Sheets("Sheet1")
For i = 13 To 2 Step -1 'Loop from the last cell, and stop at the second column
If .Cells(1, i).Value = .Cells(1, i).Offset(, -1).Value Then
.Range(.Cells(1, i), .Cells(1, i).Offset(, -1)).Merge
End If
Next i
End With
Application.DisplayAlerts = True
Should work like this …
Option Explicit
Public Sub MergeSameValuesInRow()
Const iRow As Long = 1 'the row number
Const FirstColumn As Long = 1 'first column with data in iRow
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your worksheet
Dim LastColumn As Long 'find last used column in iRow
LastColumn = ws.Cells(iRow, ws.Columns.Count).End(xlToLeft).Column
Dim StartCell As Range 'remember the start cell (first occurence of a new value)
Set StartCell = ws.Cells(iRow, FirstColumn)
Dim iCol As Long
For iCol = FirstColumn + 1 To LastColumn + 1 'loop through columns in iRow
If ws.Cells(iRow, iCol).Value <> StartCell.Value Then 'if value changed …
Application.DisplayAlerts = False 'hide merging messages
ws.Range(StartCell, ws.Cells(iRow, iCol - 1)).Merge 'merge from start cell until one before value change
Application.DisplayAlerts = True
Set StartCell = ws.Cells(iRow, iCol) 'set start cell to the next value
End If
Next iCol
End Sub
It will change this …
into this …
I am having a set of records highlighting the keywords with regards to the dates they were raised. I want to remove the duplicates in the rows and analyze the frequency of keywords on a pivot table with regards to the month they were raised.
I have used python-3 code to chunk out the keywords from the customer queries that were logged in the system. I am not sure how to strip it.
Sub RemoveDuplicatesInRow()
Dim lastRow As Long
Dim lastCol As Long
Dim r As Long 'row index
Dim c As Long 'column index
Dim i As Long
With ActiveSheet.UsedRange
lastRow = .Row + .Rows.Count - 1
lastCol = .Column + .Columns.Count - 1
End With
For r = 1 To lastRow
For c = 1 To lastCol
For i = c + 1 To lastCol 'change lastCol to c+2 will remove adjacent duplicates only
If Cells(r, i) <> "" And Cells(r, i) = Cells(r, c) Then
Cells(r, i) = ""
End If
Next i
Next c
Next r
End Sub
The macro just doesn't work.
If anyone has done anything like below please help.
What I'm looking for is macro that looks at my A2 value and copy that in column D based on value B with "_"(underscore) after it.
You would need 2 loops for this. One looping through column A and one counting up to the value in column B.
Option Explicit
Public Sub WriteValues()
With Worksheets("Sheet1")
Dim aLastRow As Long
aLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'get last used row in col A
Dim dRow As Long
dRow = 1 'start row in col D
Dim aRow As Long
For aRow = 1 To aLastRow 'loop through col A
Dim bCount As Long
For bCount = 1 To .Cells(aRow, "B").Value 'how many times is A repeated?
.Cells(dRow, "D").Value = .Cells(aRow, "A") & "_" & bCount 'write into column D
dRow = dRow + 1 'count rows up in col D
Next bCount
Next aRow
End With
End Sub
Your request is little short on particulars but this will do what you're asking.
dim i as long
with worksheets("sheet1")
for i=1 to .cells(2, "B").value2
.cells(.rows.count, "D").end(xlup).offset(1, 0) = .cells(2, "A").value & format(i, "\_0")
next i
end with
UPDATE:
Situation: I have data that I am trying to consolidate by summing rows based on the first column value (item ID number). If the ID numbers match I want the rows to be added together and the duplicate rows deleted.
I have written the following code and I am experiencing 2 issues:
1. The first time I run the code there is always a few duplicates left that were not consolidated
2. If I run the code again it sums and deletes rows even if they are not duplicates.
Any help would be much appreciated.
Sub ConsolidateRows()
Dim WB As Workbook
Dim WS As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim LastRow As Long
Dim LastCol As Long
Dim duplicate As String
Dim dupRow As Long
Dim cell As Range
Dim i As Integer
'set
Set WB = Workbooks("Book1")
Set WS = WB.Sheets("Data")
LastRow = WS.UsedRange.Rows.Count
LastCol = WS.UsedRange.Columns.Count
'Loop to consolidate, delete the duplicate rows
iRow = 1
While WS.Cells(iRow, 1).Value <> ""
duplicate = Cells(iRow, 1).Value
iRow = iRow + 1
For Each cell In WS.Range("A1:A" & LastRow).Cells
dupRow = cell.Row
If cell.Value = duplicate And iRow <> dupRow Then
For iCol = 3 To LastCol
Cells(iRow, iCol) = Application.WorksheetFunction.Sum(Cells(iRow, iCol), Cells(dupRow, iCol))
Next iCol
WS.Rows(dupRow).Delete
End If
Next cell
Wend
End Sub
You shouldn't delete rows this way, as the range you are looping will start changing and not refer to the desired cells. The quickest fix (without totally restructuring the logic) is to add a variable that holds the rows you want to delete, then delete them all after. My favorite method is using a string with commas as delimiters (easier than using an array)
Dim rowsToDelete As String
For Each cell In WS.Range("A2:A" & LastRow).Cells
jRow = cell.Row
If cell.Value = "Desired Value" Then
'Do Something
rowsToDelete = rowsToDelete & jRow & ","
End If
Next cell
If Len(rowstoDelete) > 1 Then rowstoDelete = Left(rowsToDelete,Len(rowstoDelete) - 1)
If Len(rowstoDelete) > 0 then
For i = UBound(Split(rowstoDelete,",")) to 0 Step -1
WS.Rows(Split(rowstoDelete,",")(i)).Delete
Next i
End If