In column 'M' i have hundreds of rows with multiple duplicates. I only want one record to show per duplicate when i run my macro. Below is my code and it deletes all records apart from one.
Sub DeleteRows()
With ActiveSheet
Set Rng = Range("M5:M").End(xlDown)
Rng.RemoveDuplicates Columns:=1, Header:=xlYes
End With
End Sub
It starts from M5 as this is where the data is initially. Why would it only be showing one record?
Your original attempt, Range("M5").End(xlDown), is just one cell.
Your new attempt, Range("M5:M").End(xlDown), is closer but not a valid Range reference.
Try the following:
Set Rng = Range("M5:M" & Cells(Rows.Count, "M").End(xlUp).Row)
EDIT:
If you're dealing with an entire range, you need to specify the Columns argument of Range.RemoveDuplicates, something like this:
Sub RemoveDupes()
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:V" & lastRow).RemoveDuplicates Columns:=Array(13), Header:=xlYes ' column M = 13
End Sub
Related
i am trying to copy and paste unique values of a column in vba. the challenges are the: the excel doesn't have a fixed position, the position can change based on the data. As can be seen in the picture, i want to take the unique values of the amount(abs) of Columns A and paste then besides it on columns B, i don't want to touch the amounts in column A. there are a couple of empty cells between amount and absolute amount. both amount and absolute amounts are dynamic.
enter image []1 here
As i mentioned above, the tables are dynamic. if the number of amount gets bigger the amount adds a new row and the amount(abs) always keeps the two empty cells between. Any suggestions help is apperciated?
you could use RemoveDuplicates() method of Range object:
Sub Test()
With Worksheets("MySheetName") ' change "MySheetName" to your actual sheet name
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
With .Range(.Find(What:="Amount(ABS)", LookIn:=xlValues, LookAt:=xlWhole).Offset(1), .Cells(.Count))
.Offset(, 1).Value = .Value
.Offset(1).RemoveDuplicates Columns:=1, Header:=xlNo
End With
End With
End With
End Sub
If you have access to the UNIQUE function in excel:
Determine your range of ABS Amounts using the defined variables Found and lr
Output the UNIQUE function to the right to de-dup your range
Clear the formula/spill range with a value transfer (Range.Value = Range.Value)
Sub Social_Distance()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2") '<-- Update Sheet Name
Dim Found As Range, lr As Long
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set Found = ws.Range("A1:A" & lr).Find(What:="Amount(ABS)", LookIn:=xlValues, LookAt:=xlWhole)
If Not Found Is Nothing Then
Found.Offset(, 1) = "Unique Values"
Found.Offset(1, 1) = "=UNIQUE(" & ws.Range(ws.Cells(Found.Offset(1).Row, 1), ws.Cells(lr, 1)).Address(False, False) & ")"
ws.Range(ws.Cells(Found.Offset(1).Row, 2), ws.Cells(lr, 2)).Value = ws.Range(ws.Cells(Found.Offset(1).Row, 2), ws.Cells(lr, 2)).Value
End If
End Sub
I'm very new to VBA and was hoping to get come clarification on a project. I've tried solving it with formulas but I need to still be able to enter information into cells and not have them filled with a lookup formula.
How I'm looking for it to preform is that if an object requires it to be shipped then the serial numbers and identifiers are copied and pasted in another table in the next blank row automatically.
Information divided into two tables
What I thought I needed was a segment in VBA that went like this:
Sub CopyCat()
If Range("J2") Like "*yes*" then
Range("G2:I2").copy
Range("A2:A10").end(xlup).offset(1).pasteSpecial xlpastevalues
If Range("J3") Like "*yes*" then
Range("G3:I3").copy
Range("A2:A10").end(xlup).offset(1).pasteSpecial xlpastevalues
End If
End If
End Sub
It does exactly what I ask it to do when it is only the first statement, when I add the second one to check if the next row satisfies the conditions and it does, then it places it in the same resulting cell as the first statement. If both are true I need them both to be displayed in table 1.
I'd love to take this as a learning opportunity so any information or direction you can point me in would be great! Thank you so much in advance!
I think Range("A2:A10").end(xlup) is equivalent to Range("A2").end(xlup) so will not change, but you don't want the A2 reference, you want to work up from the bottom. You will hit problems if you are going beyond A9. (Plus not sure you want nested Ifs.)
If Range("J2") Like "*yes*" Then
Range("G2:I2").Copy
Range("A10").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
If Range("J3") Like "*yes*" Then
Range("G3:I3").Copy
Range("A10").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Or to add a loop and circumvent the copy/paste you could use something like this:
Sub CopyCat()
Dim r As Long
For r = 2 To Range("J" & Rows.Count).End(xlUp).Row
If Range("J" & r) Like "*yes*" Then
Range("A10").End(xlUp).Offset(1).Resize(, 3).Value = Range("G" & r).Resize(, 3).Value
End If
Next r
End Sub
You can also do this without VBA.
In A2, you can use this formula entered as an array formula with CTRL+SHIFT+ENTER:
=INDEX($G$2:$G$4,SMALL(IF($J$2:$J$4="yes",ROW($J$2:$J$4)-ROW($J$2)+1),ROWS(J$2:J2)))
And in B2, you can put this and drag down/over from B2:D3:
=INDEX(H$2:H$4,MATCH($A2,$G$2:$G$4,0))
Finally, to hide the errors that show when there are no more matches, you can simply wrap both above formulas in IFERROR([formula above],"").
With autofilter
Sub copyRange()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim lastRow As Long
Dim filterRange As Range
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sheet2") 'change to sheet name containing delivery info
With wsSource
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
Set filterRange = .Range("G1:K" & lastRow)
Dim copyRange As Range
Set copyRange = .Range("G2:K" & lastRow)
End With
Dim lastRowTarget As Long, nextTargetRow As Long
With filterRange
.AutoFilter
.AutoFilter Field:=4, Criteria1:="yes" 'change field to whichever is the field in the range containing your company names
lastRowTarget = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
nextRowTarget = lastRowTarget + 1
Union(wsSource.Range("G2:I" & lastRow).SpecialCells(xlCellTypeVisible), wsSource.Range("K2:K" & lastRow).SpecialCells(xlCellTypeVisible)).Copy wsSource.Range("A" & nextRowTarget)
.AutoFilter
End With
End Sub
I'm using the alteration of the code from Scott Craner (which works perfectly). However, now I would like VBA to match criteria not only from one column but from 2 columns and then copy/paste as formulas to the next sheet.
Sub TransferRows()
Dim lLRow As Long
With Sheets("Sheet1")
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("B:B").AutoFilter Field:=1, Criteria1:="Cat"
.Range("B2:B" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlFormulas
.AutoFilterMode = False
End With
End Sub
Criteria1 in column "B" is "Cat", I need to add another Criteria2 ("dog") from column "C". So whenever I have "Cat" in "B" and "Dog" in "C" the entire rows are copied to Sheet2. PS. Bear in mind that I have various types of data in columns "B" and "C" so filters are imperative (also since there are 10's of thousands of rows I can't use the loop as it takes too long). Thus I would welcome advice on how to add another criteria to the aforementioned code.
Thanks
West
Try the code below (see comments inside the code):
Option Explicit
Sub TransferRows()
Dim lLRow As Long
With Sheets("Sheet1")
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Range("B1:C" & lLRow)
.AutoFilter Field:=1, Criteria1:="Cat"
.AutoFilter Field:=2, Criteria1:="dog"
End With
.Range("B2:C" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
' rest of your code goes here
End With
End Sub
I have a code that finds the last row of data in column E and selects the column to that last row. I want to be able to select associated data in columns B through D that goes with column E and then sort based on column B. So I thought I would just find the last row in column E then resize by 3 columns and sort from that selection but I keep getting a run-time error 1004 application-defined or object-defined error. I have provided the code I'm using below. Columns B through D contain data past the end of column E. Thanks!
ws.Range("E1:E" & finalrow).Resize(0, 3).Select
You may not always be starting in the first row (e.g. E1) so lastRow may not be applicable without some maths. In that case, use With ... End With statements to shorten the code while explicitly referencing the correct cell and cell ranges.
dim lastRow as long
with ws
lastRow = .cells(.rows.count, "E").end(xlup).row
'option 1
.range("B5:D" & lastRow).select
'option 2
with .range("E5:E" & lastRow)
.offset(0, -3).resize(.rows.count, 3).select
end with
'option 3
.range("E5", .cells(lastRow, "G")).offset(0, -3).select
end with
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on Range.Select and Range.Activate to accomplish your goals.
Something like:
Sub SelectLast3Cols()
Dim ws As Worksheet, lrow As Long
Set ws = Sheets("Sheet3")
lrow = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
ws.Range("B1", ws.Range("D" & lrow)).Select
End Sub
I have a list of references of cells to be deleted. The list of references is in sheet "test_url". The list of references point to cells to be deleted that are in another sheet "main_lists".
What I am after is a macro that takes all the references listed in "test_url" sheet, and select their cells in "main_lists" sheet and delete them.
The following macro is what I recorded for two references only in an attempt to demonstrate my problem that necessitated me to copy the reference from "test_url" sheet, then paste it in the NameBox of "main_urls" sheet to select the contents of the designated cell then delete its contents. This process was done manually one cell at a time for a list of 10-20 addresses/references. However, recently this list is over 2000 entries and it is growing:
Sub DeletePermittedCells()
'DeletePermittedCells Macro
Sheets("test_urls").Select
Range("B2").Select
Sheets("test_urls").Select
Selection.Copy
Sheets("main_lists").Select
Application.Goto Reference:="R200045C1"
Application.CutCopyMode = False
Selection.ClearContents
Sheets("test_urls").Select
Range("B3").Select
Selection.Copy
Sheets("main_lists").Select
Application.Goto Reference:="R247138C1"
Application.CutCopyMode = False
Selection.ClearContents
Sheets("test_urls").Select
End Sub
Can someone help with this issue please?
Try this one:
Sub DeletePermittedCells()
Dim rng As Range
Dim arr, c
With Sheets("test_urls")
'storing data in array makes your code much faster
arr = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
With Sheets("main_lists")
Set rng = .Range(arr(1, 1))
For Each c In arr
Set rng = Union(rng, .Range(c))
Next
End With
rng.ClearContents
End Sub
storing addresses in array (rather than reading each cell from worksheet directly) makes your code much faster.
Note, code assumed that your addresses stored in range B2:B & lastrow where lastrow - is row of last cell with data in column B
This assumes that the list of cells to be cleared in is column A:
Sub ClearCells()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, I As Long, addy As String
Set s1 = Sheets("test_url")
Set s2 = Sheets("main_lists")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
For I = 1 To N
addy = s1.Cells(I, 1).Value
s2.Range(addy).ClearContents
Next I
End Sub