Sub Test1()
Dim LastRow As Range
Dim cfind As Range
'Set WS = ActiveWorkbook.Worksheets("Report")
'With WS
'Set cfind = Cells.Find(what:="Order Status", lookat:=xlWhole, MatchCase:=False)
'End With
LastRow = Cells(Rows.Count, "C").End(xlUp).Row
For i = LastRow To 2 Step -1
If Range("C" & i).Value = "Canceled" Then
Range("C" & i).EntireRow.Delete
End If
Next i
End Sub
I am trying to delete the rows which has a value "Canceled" in a column which has a header "Order Status". I am currently using the column number or name. I am not sure how to use column header (Order Status) to delete the rows.
Can someone help me?
Your LastRow was a range object, should have been a long.
Sub Test1()
'not necessary now but should have been a long
'Dim LastRow As long
'not necessary now
'Dim cfind As Range
Dim col As Variant
With ActiveWorkbook.Worksheets("Report")
col = Application.Match("Order Status", .Rows(1), 0)
If Not IsError(col) Then
For i = .Cells(.Rows.Count, col).End(xlUp).Row To 2 Step -1
If .Cells(i, col).Value = "Canceled" Then
.Rows(i).EntireRow.Delete
End If
Next i
else
msgbox "no 'Order Status' here"
End If
end with
End Sub
Related
I have created below code which works like IF Col"B" any cell <> "" And Col"L" any cell = "Leop" then add row below to the active cell.
I mean I'm trying to achieve is to insert single row after certain row which contain in column B any value, and if column L in same row contains value = "Leop". Then add the row after that certain row.
But an error is appear. Compile Error: Invalid use of property on xlDown
Your help will be appreciated to fix it.
From this:
to this:
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long
Dim rng As Range
Dim rng2 As Range
Dim i As Long
Dim p As Long
Dim dat As Variant
Dim datt As Variant
Dim IRow As Long
Set ws = Thisworkbooks.Sheets("Sheet2")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B2:B" & LRow)
Set rng2 = .Range("L2:L" & LRow)
dat = rng
datt = rng2
IRow = Selection.Row
For i = LBound(dat, 1) To UBound(dat, 1)
For p = LBound(datt, 1) To UBound(datt, 1)
If dat(i, 1) <> "" And datt(p, 1) = "Leop" Then
Rows(IRow + 1).Select
Selection.Insert Shift: xlDown
End If
End Sub
It will be like in formula:
IF(AND(B2<>"",L2="Leop"),"InsertRowBelow to Row 2 If condition is met","")
and will drag it down to the lastRow.
Thisworkbooks.Sheets("Sheet2") should be Thisworkbook.Sheets("Sheet2") and missing = in Selection.Insert Shift:= xlDown
Inserting or deleting rows will change the last row number so start at the bottom and work upwards.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet, LRow As Long, r As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
LRow = .Range("B" & .Rows.Count).End(xlUp).Row
For r = LRow To 2 Step -1
If .Cells(r, "B") <> "" And .Cells(r, "L") = "Leop" Then
.Rows(r + 1).Insert shift:=xlDown
n = n + 1
End If
Next
End With
MsgBox n & " rows inserted", vbInformation
End Sub
Try this with autofilter, you dont have to loop through each row. So it will work faster for larger data.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long, cl As Range
Set ws = ThisWorkbook.Sheets("Sheet2")
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("L1:L" & LRow).AutoFilter 1, "Leop"
For Each cl In ws.Range("_FilterDatabase").SpecialCells(12).Cells
If ws.Range("B" & cl.Row) <> "" Then
cl.Offset(1).EntireRow.Insert Shift:=xlDown
End If
Next
ws.AutoFilterMode = False
End Sub
I need some help with comparing values from one column to another and delating it.
so far I have this:
Sub DelateDuplicates()
delArray = Sheets("Save").Range("B1:B") ' saved values
toDelate = Sheets("Validation").Range("B2:B").Value ' values to be checked and delated
lastRow = toDelate.Range("B1000").End(xlUp).Row ' last row
Firstrow = toDelate.Range("B2").End(xlDown).Row ' First row
Dim i As Long
For Lrow = lastRow To Firstrow Step -1
With Worksheets("Validation").Cells(Lrow, "A")
For i = 0 To UBound(delArray) ' arrays are indexed from zero
If Not IsError(.Value) Then
If .Value = delArray(i) Then
.EntireRow.Delete
Exit For
End If
End If
Next
End With
Next Lrow
End Sub
And I do have an error.
"1004 "Application-defined or Object-defined error" "
I have spent 2 days trying to figure it out so far no luck.
Any help will be appreciated.
I modified your code little bit. You can define your first rows and last row the want you want, I have kept it simple for the sake of concept
Option Explicit
Sub DelateDuplicates()
Dim Lrow As Long
Dim delarray()
With Worksheets("Save")
delarray = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
Dim i As Long
Dim lastrow As Long
Dim firstrow As Long
firstrow = 1
With Worksheets("Validation")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = lastrow To firstrow Step -1
For i = 1 To UBound(delarray)
If Not IsError(.Cells(Lrow, "A").Value) Then
If .Cells(Lrow, "A").Value = delarray(i, 1) Then
.Cells(Lrow, "A").EntireRow.Delete
Exit For
End If
End If
Next i
Next Lrow
End With
End Sub
You can avoid loops within loops by using a Dictionary Object
Option Explicit
Sub DeleteDuplicates()
Dim wsSave As Worksheet, wsValid As Worksheet
Dim iLastRow As Long, iFirstRow As Long, i As Long, n As Long
Dim dict As Object, key, cell As Range
With ThisWorkbook
Set wsSave = .Sheets("Save")
Set wsValid = Sheets("Validation")
End With
Set dict = CreateObject("Scripting.Dictionary")
' get values to delete from Column B
For Each cell In wsSave.Range("B1", wsSave.Cells(Rows.Count, "B").End(xlUp))
key = Trim(cell)
If Len(key) > 0 Then
dict(key) = cell.Row
End If
Next
' scan Validation sheet and delete matching from Save
With wsValid
iFirstRow = .Cells(2, "B").End(xlDown).Row
iLastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For i = iLastRow To iFirstRow Step -1
key = .Cells(i, "A")
If dict.exists(key) Then
.Rows(i).Delete
n = n + 1
End If
Next
End With
' resutl
MsgBox n & " rows deleted between row " & _
iFirstRow & " and " & iLastRow, vbInformation
End Sub
Want to find duplicates in a column in excel and want to popup a msgbox upon finding even 1 duplicate and it shouldn't keep on popping messages if it finds more than one duplicate.
Also, if i can use two column cell values and use that together to find duplicates, this would be also helpful.
Sub ColumnDuplicates()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
If iCntr <> matchFoundIndex Then
MsgBox ("There are duplicates in Column A")
End If
End If
Next
MsgBox ("No Duplicates in Column A")
End Sub
Expecting to print message saying that column A has duplicates or does not have duplicates
What about the use of EVALUATE?
Public Sub Test()
With ThisWorkbook.Sheets("Sheet1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
If .Evaluate("=Max(countif(A1:A" & lr & ",A1:A" & lr & "))") > 1 Then
MsgBox "Duplicates!"
Else
MsgBox "No Duplicates!"
End If
End With
End Sub
Or, parameterized:
Public Sub Test(ByVal sheet As Worksheet, ByVal columnHeading As String)
With sheet
lr = .Cells(.Rows.Count, columnHeading).End(xlUp).Row
If .Evaluate("=Max(countif(" & columnHeading & "1:" & columnHeading & lr & "," & columnHeading & "1:" & columnHeading & lr & "))") > 1 Then
MsgBox "Duplicates!"
Else
MsgBox "No Duplicates!"
End If
End With
End Sub
Now you can invoke it like this:
Test Sheet1, "A" ' find dupes in ThisWorkbook/Sheet1 in column A
Test Sheet2, "B" ' find dupes in ThisWorkbook/Sheet2 in column B
Test ActiveWorkbook.Worksheets("SomeSheet"), "Z" ' find dupes in "SomeSheet" worksheet of whatever workbook is currently active, in column Z
Throw your values in a dictionary
Sub ColumnDuplicates()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row
Set oDictionary = CreateObject("Scripting.Dictionary")
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
If oDictionary.Exists(Cells(iCntr, 1).Value) Then
MsgBox ("There are duplicates in Column A")
Exit Sub
Else
oDictionary.Add Cells(iCntr, 1).Value, Cells(iCntr, 1).Value
End If
End If
Next
MsgBox ("No Duplicates in Column A")
End Sub
If you have Excel 2007+ then this will be faster. This code ran in 1 sec for 200k rows
Sub Sample()
Debug.Print Now
Dim ws As Worksheet
Dim wsTemp As Worksheet
Set ws = Sheet1
Set wsTemp = ThisWorkbook.Sheets.Add
ws.Columns(1).Copy wsTemp.Columns(1)
wsTemp.Columns(1).RemoveDuplicates Columns:=1, Header:=xlNo
If Application.WorksheetFunction.CountA(ws.Columns(1)) <> _
Application.WorksheetFunction.CountA(wsTemp.Columns(1)) Then
Debug.Print "There are duplicates in Col A"
Else
Debug.Print "duplicates found in Col A"
End If
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Debug.Print Now
End Sub
I used the below code to generate 200k records in Col A
Sub GenerateSampleData()
Range("A1:A200000").Formula = "=Row()"
Range("A1:A200000").Value = Range("A1:A200000").Value
Range("A10000:A20000").Value = Range("A20000:A30000").Value
End Sub
Code execution
I found this code on another post that will single out a line - but it deletes all others EXCEPT the specified line.
I work with large numbers of address lists and I need something I can run that will identify and delete rows with addresses that we've been asked not to mail to. I've just discovered VBA some I'm extremely green. But I'd like to have a module that allows me to add multiple addresses as the list grows.
Sub DeleteRows()
Dim i as long, LastRow As long
with activesheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).row
For i = LastRow to 2 step -1
If .Cells(i, 1).Value <> "certain value" Then
.Rows(i).Delete
End If
Next i
End With
End Sub
Simply change this:
If .Cells(i, 1).Value <> "certain value" Then - where cell value different then "certain value"
to this:
If .Cells(i, 1).Value = "certain value" Then - where cell value equal to "certain value"
Sub DeleteRows()
Dim i As Long, LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.count, 1).End(xlUp).row
For i = LastRow To 2 Step -1
If .Cells(i, 1).value = "certain value" Then
.Rows(i).Delete
End If
Next i
End With
End Sub
You could use Union to gather the qualifying rows in one go and delete. Also, have a separate sheet where you store the addresses to match on. Read those addresses into an array, then loop the sheet where data is to be deleted from and check whether a given address is found in your array. If found, use Union to store that cell for later deletion.
At the end of looping the data to check, delete the rows associated with the stored cells in the union'd range object in one go.
Option Explicit
Public Sub DeleteThemRows()
Dim arr(), unionRng As Range, i As Long, lastRow As Long, rng As Range
Dim wsAddress As Worksheet, wsDelete As Worksheet
Set wsAddress = ThisWorkbook.Worksheets("Addresses")
Set wsDelete = ThisWorkbook.Worksheets("DataToDelete")
With wsAddress '<= Assume addresses stored in column A starting from cell A1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Select Case lastRow
Case 1
ReDim arr(1, 1): arr(1, 1) = .Range("A1").Value
Case Is >= 2
arr = .Range("A1:A" & lastRow).Value
End Select
arr = Application.WorksheetFunction.Index(arr, 0, 1)
End With
With wsDelete '<==Assume address column to check is column A
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim loopRange As Range
Set loopRange = .Range("A1:A" & lastRow)
If Application.WorksheetFunction.CountA(loopRange) = 0 Then Exit Sub
For Each rng In loopRange.SpecialCells(xlCellTypeConstants)
If Not IsError(Application.Match(rng.Value, arr, 0)) Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, rng)
Else
Set unionRng = rng
End If
End If
Next
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
End Sub
You could use Debug.Print unionRng.Address first to check what will be deleted.
Sub FastDelete()
Dim rng As Range, rngData As Range, rngVisible As Range
Const CRITERIA$ = "SOME_VALUE"
Set rng = Range("A1").CurrentRegion '//Whole table
With rng '//Table without header
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
'// Filter by column "A"
rng.AutoFilter Field:=1, Criteria1:=CRITERIA
On Error Resume Next '//In case if no values filtered
Set rngVisible = rng.SpecialCells(xlCellTypeVisible)
If Err = 0 Then
rngVisible.EntireColumn.Delete
End If
On Error GoTo 0
End Sub
I need help modifying this code to match First and Last names across 2 worksheets, then remove matches from the Sub sheet. At the moment it only matches 2 columns across 1 sheet. Specifics:
How do i change this code so Names on 'Sheet 1' Column 'B' are Matched to names on 'sheet 2' column 'E' & all matches are deleted from 'Sheet 1". Same is repeated for 'Sheet 1' Column 'C' to 'Sheet 2' Column 'F'.
Sub CompareNames()
Dim rngDel As Range
Dim rngFound As Range
Dim varWord As Variant
Dim strFirst As String
With Sheets("ADULT Sign On Sheet")
For Each varWord In Application.Transpose(.Range("A1", .Cells(.Rows.Count,"A").End(xlUp)).Value)
If Len(varWord) > 0 Then
Set rngFound = .Columns("B").Find(varWord, .Cells(.Rows.Count, "B"), xlValues, xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If Not rngDel Is Nothing Then Set rngDel = Union(rngDel, rngFound) Else Set rngDel = rngFound
Set rngFound = .Columns("B").Find(varWord, rngFound, xlValues, xlPart)
Loop While rngFound.Address <> strFirst
End If
End If
Next varWord
End With
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
Set rngFound = Nothing
End Sub
Loops through all values in Sheet1 Column B. If that value is found in Sheet2 Column E, the entire row in Sheet1 is deleted. Then it loops through all values in Sheet1 Column C. If that value is found in Sheet2 Column F, the entire row in Sheet1 is deleted.
Sub DeleteCopy()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
LastRow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
DestLast = Sheets("Sheet2").Range("E" & Rows.Count).End(xlUp).Row
For CurRow = 2 To LastRow 'Assumes your first row of data is in row 2
If Not Sheets("Sheet2").Range("E2:E" & DestLast).Find(Sheets("Sheet1").Range("B" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("Sheet1").Range("B" & CurRow).Value = ""
Else
End If
Next CurRow
LastRow = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
DestLast = Sheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Row
For CurRow = 2 To LastRow 'Assumes your first row of data is in row 2
If Not Sheets("Sheet2").Range("F2:F" & DestLast).Find(Sheets("Sheet1").Range("C" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("Sheet1").Range("C" & CurRow).Value = ""
Else
End If
Next CurRow
End Sub
Try this, you will have to call it twice once with the first criteria and then again with the second critiera
I think I have it set up properly for the first criteria
Sub DeleteIfMatchFound()
Dim SearchValues As Variant
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim sLR As Long, tLR As Long, i As Long
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
sLR = wsSource.Range("B" & wsSource.Rows.Count).End(xlUp).Row
tLR = wsTarget.Range("E" & wsSource.Rows.Count).End(xlUp).Row
SearchValues = wsSource.Range("B2:B" & sLR).Value
For i = 1 To (tLR - 1)
If Not IsError(Application.match(SearchValues(i, 1), wsTarget.Range("E2:E" & tLR), 0)) Then
wsTarget.Rows(i + 1).Delete
End If
Next i
End Sub