Delete Replicates from the first column - excel

i am looking for a way to delete rows in a column that countains replicates in the first column. The function RemoveDuplicates doesnt seems to work properly , do you have any idea ? Thanks.

i found this on internet. works great.
deleting duplicate rows based on a column of cells that I highlighted.
Public Sub DeleteDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")
N = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If
V = Rng.Cells(R, 1).Value
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Note that COUNTIF works oddly with a Variant that is equal to vbNullString.
' Rather than pass in the variant, you need to pass in vbNullString explicitly.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If V = vbNullString Then
If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
Rng.Rows(R).EntireRow.Delete
N = N + 1
End If
Else
If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
Rng.Rows(R).EntireRow.Delete
N = N + 1
End If
End If
Next R
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)
End Sub

Related

Make columns and rows mandatory

i need to make rows and columns mandatory before close
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lr As Long
Dim r As Long
' Activate correct sheet
' Sheets("Sheet1").Activate
' Find last row in column A with data
lr = Cells(Rows.Count, "A").End(xlUp).Row
' Loop through all rows with data in column A
For r = 2 To lr
' Check to see if column A is not zero
If Cells(r, "A") <> 0 Then
' Check to see that columns B and C are not empty
If Cells(r, "B") = "" Or Cells(r, "C") = "" Then
Cancel = True
MsgBox "Please fill in columns B and C", vbOKOnly, "ROW " & r & " INCOMPLETE!!!"
End If
End If
Next r
End Sub
I made it a bit faster and more user friendly using:
Arrays to iterate data.
a single error message at the end rather than several.
I also made the requested change to allow code to work with and column width requirements. Just change the ColumnsToCheck = 6 to however many columns.
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lRow As Long
Dim I As Long
Dim ColumnsToCheck As Long
Dim MissedItem As Boolean
Dim Mitem As Boolean
Dim M As Long
Dim SrcRG As Range
Dim SrcArr
Dim OutMessage As String
' *** This is the number of columns you are checking INCLUDING Column A
ColumnsToCheck = 6 'Minimum = 2
' Find last row in column A with data
lRow = Cells(Rows.Count, "A").End(xlUp).Row
Set SrcRG = Range("A1").Resize(lRow, ColumnsToCheck)
SrcArr = SrcRG
MissedItem = False
OutMessage = "Please fill in data columns 2 through " & ColumnsToCheck & "." & vbCrLf & _
"Missing Data found in the following locations." & vbCrLf
' Loop through all rows with data in column A
For I = 2 To lRow
' Check to see if column A is not zero
If SrcArr(I, 1) <> 0 Then
' Check to see that columns B and C are not empty
For M = 2 To ColumnsToCheck
Debug.Print SrcArr(I, M)
If SrcArr(I, M) = "" Then Mitem = True
Next M
If Mitem = True Then
MissedItem = True
OutMessage = OutMessage & vbCrLf & _
" Missing data at row # " & I
Mitem = False
End If
End If
Next I
If MissedItem = True Then
Cancel = True
MsgBox OutMessage, vbOKOnly, "Error: Missing Data"
End If
End Sub

Excel VBA Iterate through data validation lists and copy range from worksheet to a new worksheet

Option Explicit
Sub LoopThroughValidationList()
Dim lst As Variant
Dim rCl As Range
Dim str As String
Dim iX As Integer
str = Range("B1").Validation.Formula1
On Error GoTo exit_proc:
If Left(str, 1) = "=" Then
str = Right(str, Len(str) - 1)
For Each rCl In Worksheets(Range(str).Parent.Name).Range(str).Cells
Range("B1").Value = rCl.Value
Next rCl
Else
lst = Split(str, ",")
For iX = 0 To UBound(lst)
Range("B1").Value = lst(iX)
Next iX
End If
Exit Sub
exit_proc:
MsgBox "No validation list ", vbCritical, "Error"
End Sub
I am tring to iterate through two data validation lists and copy a range in sheet1 to sheet2 for every iteration. This code iterates through one data validation drop down and doesn't copy the range I want in sheet1.
Change data validation list1 to first item in list
Change data validation list2 to first item in list
Copy range from sheet1 to sheet2, first item in list + first item in list + copied range
Repeat
UPDATE 2018-07-27:
Here are the formulas for my data validation list ='A. Dashboard2'!$B$1:$V$1, ='A. Dashboard'!$B$1:$V$1. And also =OFFSET('A. Dashboard'!$A$1;1;MATCH($F$4;'A. Dashboard'!$A$1:$V$1;0)-1;COUNTA(OFFSET('A. Dashboard'!$A$1;1;MATCH($F$4;'A. Dashboard'!$A$1:$V$1;0)-1;55;1));1)
Untested, written on mobile. See if it works and whether it does what you want.
Code expects that validation list 1 will always begin with an = sign and will be a reference to a range -- and that validation list 2 is a ; delimited list.
Code expects sheets called Dashboard and Result to already exist.
Code will attempt to copy the various ranges (from Dashboard sheet) to a new row on the Result sheet for each item in the validation lists.
Option Explicit
Sub LoopThroughValidationLists()
With thisworkbook
Dim resultsRange as range 'First cell to output to'
Set resultsRange = . worksheets("Result").range("A1")
with .worksheets("Dashboard")
dim list1range as range
set list1range = .range("G3")
dim list2range as range
set list2range = .range("W3")
dim rangeToCopy1 as range
set rangeToCopy1 = .range("K9:K40")
dim rangeToCopy2 as range
set rangeToCopy2 = .range("Z9:Z40")
end with
end with
dim list1formula as string
on error resume next
list1formula = list1range.Validation.Formula1
on error goto 0
dim list2formula as string
on error resume next
list2formula = list2range.Validation.Formula1
on error goto 0
if Len(list1formula) = 0 then
MsgBox("Validation list1 not detected.")
exit sub
elseif ASC(list1formula) <> 61 then
MsgBox("Expected list1 to begin with '='")
exit sub
elseif instrrev(list1formula,"!",-1,vbbinarycompare) > 0 then
List1formula = mid$(list1formula,instrrev(list1formula,"!",-1,vbbinarycompare)+1)
List1formula = replace(list1formula,"$",vbnullstring,1,vbbinarycompare)
End if
if Len(list2formula) = 0 then
MsgBox("Validation list2 not detected.")
exit sub
end if
dim list1items as range
on error resume next
set list1items = thisworkbook.worksheets("A. Dashboard").range(mid$(list1formula,2))
on error goto 0
if list1items is nothing then
MsgBox("Expected validation list1 to refer to a range:" & VBnewline & vbnewline & list1formula)
exit sub
end if
dim list2items() as string
list2items() = split(list2formula, ";")
if list1items.cells.count <> (ubound(list2items) +1) then
MsgBox ("Count of items in list1 is not the same as count of items in list2:" & vbnewline & vbnewline & "List1 = " & list1items.cells.count & " cells " & vbnewline & "List2 = " & (ubound(list2items) +1) & " items")
Exit sub
end if
dim cell as range
dim listIndex as long
application.calculation = xlCalculationManual
application.screenupdating = false
with resultsRange
for each cell in list1range
list1range.value2 = cell.value2
list2range.value2 = list2items(listindex)
list1range.parent.calculate ' Sheet needs to re-calculate '
' Column 1 = list1'
' Column 2 = list2'
' Columns 3 to 34 = K9:K40'
' Columns 35 to 66 = Z9:Z40'
.offset(listindex, 0) = cell.value2 ' Value from list1'
.offset(listindex, 1) = list2items(listindex) ' Value from list2'
rangeToCopy1.copy
'below needs to appear on a new line'
.offset(listIndex, 2).pastespecial paste:=xlPasteValuesAndNumberFormats,
transpose:=True
rangeToCopy2.copy
'below needs to appear on a new line'
.offset(listIndex, 34).pastespecial paste:=xlPasteValuesAndNumberFormats,
transpose:=True
listindex = listindex +1
next cell
application.calculation = xlautomatic
application.screenupdating = true
end with
End Sub

trying to delete hidden names by selection excel macro

I'm trying to delete hidden Names but with a rule that I choose what hidden Name to delete and what not.
Using the code from Microsoft support I managed to make a list of the names
on a log sheet and added a column that when I enter 1 next to it I want to not delete the name, and when I leave it blank U want it to remove the name.
code from Microsoft support (https://support.microsoft.com/en-us/help/119826/macro-to-remove-hidden-names-in-active-workbook)
here is my code:
Sub clean_names()
Application.ScreenUpdating = False
On Error Resume Next
Set nms = ActiveWorkbook.Names
MsgBox (nms.Count)
For R = 1 To nms.Count
Name_Name = nms(R).Name
Name_Referance = nms(R).RefersTo
'###########ActiveWorkbook.Names(Name_Name).Delete
'ActiveWorkbook.nms(R).Delete
Sheets("LOG").Cells(R + 1, 1).Value = Name_Name
Sheets("LOG").Cells(R + 1, 2).Value = "'" + Name_Referance
'Application.StatusBar = R
Next R
'Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
'================================================================
Sub DelNames()
Dim xName As Variant
Dim Indx As Integer
Dim Vis As Variant
Cells(2, 1).Select
If (ActiveCell = "") Then Exit Sub
Indx = 1
Do
If (ActiveCell.Offset(Indx, 2) = "") Then
xName = ActiveCell.Offset(Indx, 0).Value
If xName.Visible = True Then
Vis = "Visible"
Else
Vis = "Hidden"
End If
xName.Delete
End If
Indx = Indx + 1
Loop While Len(ActiveCell.Offset(Indx, 0))
End Sub
How can i make this code work ?
Try the code below, it will loop thorugh all rows in Column A, check if column C is empty, and will delete that Name from your workbook.
Note: I've commented 5 lines from your original code, since according to your post you don't care if the Names are Visible or not, you want to delete them based on the value in Column C.
Code
Option Explicit
Sub DelNames()
Dim xName As Name
Dim Indx As Long
Dim Vis As Variant
Dim LastRow As Long
With Worksheets("LOG")
If IsEmpty(.Range("A2").Value) Then Exit Sub
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row '<-- get last row in column A (where you have a NamedRange)
For Indx = 2 To LastRow
If .Range("C" & Indx).Value = "" Then
' set xName with the text entered in column A (as the Named Range Name)
Set xName = ThisWorkbook.Names(.Range("A" & Indx).Value)
' not sure you need the 5 lines with the If criteria below so I Commented them for now
'If xName.Visible = True Then
' Vis = "Visible"
'Else
' Vis = "Hidden"
'End If
xName.Delete
End If
Next Indx
End With
End Sub

Modify VBA code to remove all duplicates apart from first 2 rows

I have found the following code which does a good job for me at extracting the data I need but I now need to modify it. Currently it removes all duplicate rows based on active column and keeps the first row.
I need to run it on a different column and remove all duplicates apart from the first 2 rows this time.
I don't know how to change it.
Many thanks
Public Sub DeleteDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")
N = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If
V = Rng.Cells(R, 1).Value
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Note that COUNTIF works oddly with a Variant that is equal to vbNullString.
' Rather than pass in the variant, you need to pass in vbNullString explicitly.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If V = vbNullString Then
If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
Rng.Rows(R).EntireRow.Delete
N = N + 1
End If
Else
If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
Rng.Rows(R).EntireRow.Delete
N = N + 1
End If
End If
Next R
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)
End Sub
To preserve the first 2 rows change the For Loop from
For R = Rng.Rows.Count To 2 Step -1
to:
For R = Rng.Rows.Count To 3 Step -1
To work on a different column to ActiveColumn change this line
Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns(ActiveCell.Column))
To something like:
Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Range("A1").EntireColumn))
(Where column A is the column to be used)

Loop through filter criteria

I've been trying to figure this out but no progress...
I have a filter (COLUMN D) and I'm trying to create a loop to each criteria (I got at least 1000 criterias) on my filter.
Ex: For each criteria on filter (column D), I'll run a range copy...
That code isnt working at all:
Sub WhatFilters()
Dim iFilt As Integer
iFilt = 4
Dim iFiltCrit As Integer
Dim numFilters As Integer
Dim crit1 As Variant
ActiveSheet.Range("$A$1:$AA$4635").AutoFilter Field:=16, Criteria1:= _
"Waiting"
numFilters = ActiveSheet.AutoFilter.Filters.Count
Debug.Print "Sheet(" & ActiveSheet.Name & ") has " & numFilters & " filters."
If ActiveSheet.AutoFilter.Filters.Item(iFilt).On Then
crit1 = ActiveSheet.AutoFilter.Filters.Item(iFilt).Criteria1
For iFiltCrit = 1 To UBound(crit1)
Debug.Print "crit1(" & iFiltCrit & ") is '" & crit1(iFiltCrit)
'Copy everything
Next iFiltCrit
End If
End Sub
My mistake seems to be identifying my filter column...
I realize this was asked a while ago but I havent seen anything that I consider copy-paste ready. here is what I came up with. It should work for unlimited criteria. It does create a single new sheet called "temp" that can be deleted once finished.
Dim currentCell As Long
Dim numOfValues As Long
Sub filterNextResult()
' copy and move the data from the data sheet, column A (can be changed if needed) to a new sheet called "temp"
' check to make sure there is at least 1 data point in column A on the temp sheet
If currentCell = 0 Then
Application.ScreenUpdating = False
Call createNewTemp
Application.ScreenUpdating = True
End If
' find the total number of unique data points we will be filtering by in column A of the temp sheet
If numOfAccounts = 0 Then
Application.ScreenUpdating = False
Call findNumOfValues
Application.ScreenUpdating = True
End If
With Sheet1.UsedRange
.AutoFilter 1, Worksheets("temp").Range("A" & currentCell).Value
currentCell = currentCell + 1
' check to make sure we havent reached the end of clumn A. if so exit the sub
If numOfValues + 1 = currentCell Then
MsgBox ("This was the last value to filter by")
Exit Sub
End If
End With
End Sub
'sub that will look for the number of values on the temp sheet column a
Private Sub findNumOfValues()
' count the number of non empty cells and assign that value (less 1 for the title in our case) to the numOfValues
numOfValues = Worksheets("temp").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
End Sub
Private Sub createNewTemp()
Sheet1.Range("A:A").Copy
ActiveWorkbook.Sheets.Add.Name = "temp"
' remove duplicates
Worksheets("temp").Range("A1").Select
With ActiveWorkbook.ActiveSheet
.Paste
.Range("A:A").RemoveDuplicates Columns:=Array(1), Header:=xlYes
End With
' check to make sure there are vlaues in the temp sheet
If Worksheets("temp").Range("A2").Value = "" Then
MsgBox "There are no filter values"
End
Else
currentCell = 2
End If
Sheet1.Activate
Sheet1.Range("A1").Select
Selection.AutoFilter
End Sub
This worked for me
Sub WhatFilters()
Dim iFilt As Integer
Dim i, j As Integer
Dim numFilters As Integer
Dim crit1 As Variant
If Not ActiveSheet.AutoFilterMode Then
Debug.Print "Please enable AutoFilter for the active worksheet"
Exit Sub
End If
numFilters = ActiveSheet.AutoFilter.Filters.Count
Debug.Print "Sheet(" & ActiveSheet.Name & ") has " & numFilters & " filters."
For i = 1 To numFilters
If ActiveSheet.AutoFilter.Filters.Item(i).On Then
crit1 = ActiveSheet.AutoFilter.Filters.Item(i).Criteria1
If IsArray(crit1) Then
'--- multiple criteria are selected in this column
For j = 1 To UBound(crit1)
Debug.Print "crit1(" & i & ") is '" & crit1(j) & "'"
Next j
Else
'--- only a single criteria is selected in this column
Debug.Print "crit1(" & i & ") is '" & crit1 & "'"
End If
End If
Next i
End Sub

Resources