Im completely novice on VBA but i found no solution in google so far. i find 2 seperate code but when combining the solution didnt find out
I have a issue of deleting duplicate row with condition
column b column z
1 22/1/2019
2 22/1/2019
1 23/1/201
2 23/1/2019
outcome
column b column z
1 23/1/2019
2 23/1/2019
My code ( having problem when nested do while with for )
Sub Macro1()
Dim RowsToDelete As Range, innerRow As Long
Set TheRng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("B:Z"))
xx = TheRng.Value
innerRow = 1
For i = UBound(xx) To 2 Step -1
Do While ActiveSheet.Range("b" & Row) <> ""
If ActiveSheet.Range("b" & Row) = ActiveSheet.Range("b" & innerRow) Then
For j = i - 1 To 1 Step -1
If ActiveSheet.Range("Z" & Row) < ActiveSheet.Range("Z" & innerRow) Then
Set RowsToDelete = Union(IIf(RowsToDelete Is Nothing, TheRng.Cells(i, 1), RowsToDelete), TheRng.Cells(i, 1))
Exit For
End If
Next j
Loop
RowsToDelete.EntireRow.Select 'Delete
End Sub
It looks like you want to delete duplicates from column B but keep the row with the newest date in column Z.
RemoveDuplicates typically deletes the duplicate with the largest row number (closest to the bottom of the data) so Sort the data with the date descending to leave the latest date at the top and remove duplicates.
Sub Macro1()
With Worksheets("sheet1")
'With .Range(.Cells(1, "B"), .Cells(.Rows.Count, "Z").End(xlUp))
With Intersect(.UsedRange, .Range("B:Z"))
.Sort key1:=.Columns(1), order1:=xlAscending, _
key2:=.Columns(.Columns.Count), order2:=xlDescending, _
Header:=xlNo
.RemoveDuplicates Columns:=1, Header:=xlNo
End With
End With
End Sub
Related
I have two problems I'm trying to solve.
First, I'm trying to sort by column AP (this column contains a 1 for every row where column AI is not blank).
The code is supposed to sort so that anytime column AP = 1, the rows that have a 1 appear at the bottom.
Unfortunately, this keeps the rows with a 1 in the middle, and doesn't logically order by putting the zeroes at the top and the ones at the bottom.
Sub SortSheet()
Dim lastrow As Long
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
Range("A2:AP" & lastrow).Sort key1:=Range("AP2:AP" & lastrow), _
order1:=xlDescending, Header:=xlNo
End Sub
Second, when we sort by column AP, I want to insert three blank rows between where the sorted rows change from 0 to 1.
So in other words, if the first 5 rows are 0 and the 6th row is a 1, I want to insert three blank rows above row 6.
Maybe you need to paste column AP as values before sorting (if they are linked to a cell). The code correctly sorted AP for me.
Here's the full code
Sub SortSheet()
Dim lastrow As Long
Dim firstzero As Range
Dim x As Long
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
Range("A2:AP" & lastrow).Copy
Range("A2:AP" & lastrow).PasteSpecial Paste:=xlPasteValues
Range("A2:AP" & lastrow).Sort key1:=Range("AP2:AP" & lastrow), _
order1:=xlDescending, Header:=xlNo
Range("AP2:AP" & lastrow).Find(0).Select
For x = 1 To 3
ActiveCell.EntireRow.Select
Selection.Copy
Selection.Insert Shift:=xlUp
Application.CutCopyMode = False
Selection.ClearContents
Next x
End Sub
Problem
I have a sheet in which first i have to filter the last column.
For each unique value present in last column, I have to copy data from first column to last-1 column
Then I have to add new sheet and need to paste this data in new sheet.
I repeat same process 3 for each unique value present in last column. Like in last column is of language. so first sort this column. then copy and paste data for each language in new sheets.
Sub LoopThroughAllItemsInFilters()
Range("G2", Range("G" & Cells(Rows.Count, 1).End(xlUp).Row)).Select
Selection.Copy
Columns("L").Select
ActiveSheet.Paste
ActiveSheet.Range("$L$1:$L$10000").RemoveDuplicates Columns:=1, Header:=xlYes
Dim ArrayDictionaryofItems As Object, Items As Variant, i As Long, Item As Variant
Set ArrayDictionaryofItems = CreateObject("Scripting.Dictionary")
With ActiveSheet
'show autofilter if not already shown on all rows
If Not .AutoFilterMode Then .UsedRange.AutoFilter
If .Cells.AutoFilter Then .Cells.AutoFilter
'Create list of unique items in column G that get filled into ArrayDictionaryofItems
Dim annoying As Double
If Range("G3").Value <> "" Then
annoying = 2
Items = Range(.Range("L2"), .Cells(Rows.Count, "L").End(xlUp))
'Fills ArrayDictionaryofItems to the UBOUND (max) count of unique items in column L.
For i = 1 To UBound(Items, 1)
ArrayDictionaryofItems(Items(i, 1)) = 1
Next
Else
Item = Range("G2").Value
annoying = 1
End If
'Filter multiple items if annoying is set to equal 2 because G3 is blank
If annoying = 2 Then
For i = 1 To UBound(Items, 1)
Sheets.Add After:=Sheets(i)
Next i
Sheets("DEFAULTERS").Select
Dim x As Double
x = 2
For Each Item In ArrayDictionaryofItems.keys
erow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
'autofilter on column b with this driver
.UsedRange.AutoFilter field:=7, Criteria1:=Item
Columns("A:G").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets(x).Select
Columns("A:G").Select
ActiveSheet.Paste
Sheets("DEFAULTERS").Select
x = x + 1
Next Item
GoTo LINE99:
End If
'Filter a single item in column since G3 is blank and there is only one item in column G to filter
If annoying = 1 Then
Sheets.Add After:=ActiveSheet
Sheets("DEFAULTERS").Select
Item = Range("G2").Value
.UsedRange.AutoFilter field:=7, Criteria1:=Item
End If
Columns("A:G").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets(2).Select
Columns("A:G").Select
ActiveSheet.Paste
Sheets("DEFAULTERS").Select
End With
LINE99:
With ActiveSheet
If .AutoFilterMode Then .UsedRange.AutoFilter
End With
End Sub
In this project, I am looking to delete duplicates based on the ID number by keeping the latest entries. Additionally, I want to keep every cell in Column D and onward from the previous entries. This ultimately means that the latest entries will be replaced in the previous entries’ row. Please see tables below for more clarity:
Based on the example given above, the result I am looking for is to:
Delete duplicates based on the ID from columns A to C and keep the latest entries
Keep Columns D to H from the previous entries
Replace previous entries by the latest ones in the previous entries’ row.
In other words: Update Columns A to C without modifying Columns D to H
So, the initial code that I had was as follow. It only kept the previous entries and kept columns D to H:
Sub Delete_Duplicates()
Sheet5.Range("$A$1:$H$29999").RemoveDuplicates Columns:=Array(1) _
, Header:=xlYes
End Sub
The table below shows what i would obtain:
The next code I did was to keep the newest entries, but this deletes my entries in column D to H:
Sub Delete_Duplicates_2()
Dim Rng As Range, Dn As Range, n As Long
Dim Lst As Long, nRng As Range
Set Rng = Sheet5.Range("$A$2:$H$29999")
Lst = Range("A" & Rows.Count).End(xlUp).Row
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For n = Lst To 1 Step -1
If Not .Exists(Range("A" & n).Value) Then
.Add Range("A" & n).Value, Nothing
Else
If nRng Is Nothing Then
Set nRng = Range("A" & n)
Else
Set nRng = Union(nRng, Range("A" & n))
End If
End If
Next n
If Not nRng Is Nothing Then
nRng.EntireRow.Delete
End With
End Sub
The table below shows what I would obtain:
I am open to any suggestions and thank you for your help!
Try this solution - since you're essentially working with a string in your date column, we have to split out the number and test to see if it's greater or less than the other week's number:
Option Explicit
Sub Delete_Duplicates()
Dim i As Long, j As Long
Dim id As String, weeknum As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
id = Cells(i, 1).Value
weeknum = Split(Cells(i, 3).Value, " ")(1)
For j = i - 1 To 2 Step -1
If Cells(j, 1).Value = id Then
If Split(Cells(j, 3).Value, " ")(1) < weeknum Then
Rows(j).Delete
i = i - 1
Else
Rows(i).Delete
Exit For
End If
End If
Next j
Next i
End Sub
Below is the current (incomplete) code I'm using which works fine to delete any one given row, but what I really need to do is identify rows which meet certain criteria:
Cell Value in Column L > 90%
OR
Cell Value in Column M > 90%
Then if either of those is true I need to find the Cell Value in same row Column G and delete all rows which contain that same Value in Column G.
Sub sbDelete_Rows_Based_On_Multiple_Criteria()
Dim lRow As Long
Dim iCntr As Long
lRow = Cells(Rows.Count, "G").End(xlUp).Row
For iCntr = lRow To 2 Step -1
If Cells(iCntr, "L") > 0.90 OR Cells(iCntr, "M") > 0.90 Then
Cells(iCntr, "G").EntireRow.Delete
End If
Next iCntr
End Sub
--
What I hope to accomplish in my example would result in the only Serial # which is NOT deleted would be 1910910
thank you in advance for your assistance.
Sub ToDelete()
Dim last_row&
'// NOTE! The code assumes that range:
'// 1) starts in column A
'// 2) ends in column O
last_row = Cells(Rows.Count, "G").End(xlUp).Row
'// Helper column 1
With Range("P2:P" & last_row)
.Formula = "=IF(OR(M2>0.9,L2>0.9),1,0)"
.Value = .Value 'Overwrite formula
End With
'// Helper column 2
With Range("Q2:Q" & last_row)
.Formula = "=IF(SUMIF(G:G,G2,P:P)>0,1,0)"
.Value = .Value 'Overwrite formula
End With
Rows(1).CurrentRegion.AutoFilter Field:=17, Criteria1:=1
Rows("2:" & last_row).EntireRow.Delete
ActiveSheet.AutoFilterMode = False 'Remove filter
Columns("P:Q").Delete 'Remove helper columns
End Sub
I am writing a code where basically I need to follow the sequence in logic. I am going through all the lines
Set rep = Sheets("Details")
For i = 2 To n
If Sheets("Work").Range("A:A").Find(Worksheets("Work_report").Range("E" & i).Value, lookat:=xlWhole) Is Nothing Then
Else:
o = rep.Range("A" & Rows.Count).End(xlUp).Row + 1
rep.Range("A" & o).Value = "FT_EXCEL"
rep.Range("B" & o).Value = Sheets("Start").Range("C5") & "AB" & o - 1
End If
Next i
So this the last line (there are more than 50 in original code) returns me a value of the cell C5 (20170331) & AB & the o minus 1 (because I have started at 2 (1st line header)). So this is giving 20170331AB1, but it should give 20170331AB01 (zero before the 0). This sequence works like a charm after 10, but before ten when I need to add a zero - I got stuck.
Any ideas? Thank you.
Try this:
rep.Range("B" & o).Value = Sheets("Start").Range("C5") & "AB" & Format(o - 1, "00")
you can do it in one shot with exploiting AutoFilter() method's operator xlFilterValues value
Sub main()
Dim rep As Worksheet
Dim criteriaArr As Variant
With Worksheets("Work_report") '<--| reference "Work_report" sheet
criteriaArr = Application.Transpose(.Range("E2", .Cells(.Rows.Count, "E").End(xlUp)).Value) '<--| store its column E cells content from row 2 down to last not empty one
End With
Set rep = Sheets("Details")
With Worksheets("Work") '<--| reference "Work" sheet
With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one
.AutoFilter Field:=1, Criteria1:=criteriaArr, Operator:=xlFilterValues '<--| filter it with "Work_report" sheet column E content
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any filtered cells other then headers
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<--| reference filtered cells skipping header
rep.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count).Value = "FT_EXCEL" '<--| write 'rep' sheet column A corresponding cells content
With rep.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count)
.Formula = "=CONCATENATE(Start!$C$5,""AB"",TEXT(ROW(),""00""))" '<--| '<--| write 'rep' sheet column B corresponding cells content
.Value = .Value
End With
End With
End If
End With
.AutoFilterMode = False
End With
End Sub