I have a few thousand columns of data and I need to remove the duplicate records in each individual column before looking at the next column. I have this code that was created when I recorded the Macro, but it's only doing the columns that I specifically entered, and I want it to continue looking at future columns until there is no more data.
Sub DUPLICATE()
'
' DUPLICATE Macro
'
' Keyboard Shortcut: Ctrl+d
'
ActiveSheet.Range("$T$1:$T$12").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("U:U").Select
ActiveSheet.Range("$U$1:$U$12").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("V:V").Select
ActiveSheet.Range("$V$1:$V$12").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("W:W").Select
ActiveSheet.Range("$W$1:$W$12").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("X:X").Select
ActiveSheet.Range("$X$1:$X$12").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
This should do the trick:
Sub DeleteDublicates()
Dim i As Integer
For i = 1 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column Step 1
ActiveSheet.Range(Cells(1, i), Cells(Cells(Rows.Count, i).End(xlUp).row, i)).RemoveDuplicates Columns:=1, Header:=xlNo
Next i
End Sub
Related
Having tried for many hours without a solution, I am asking for help to please clear the contents of Columns A through H from first row where Col G = - to row 50000. I have tried many approaches without success. Users currently have instructions to do this manually, but I sure wish it could be automated by adding it to the code below. Deleting the rows is no good because it upsets array formulas elsewhere that use this data.
Sub CopyPasteToPrYrData()
'
' CopyPasteToPrYrData Macro
'
' Keyboard Shortcut: Ctrl+Shift+C
'
Sheets("Barrel List by Producer").Range("AD3:AK30000").Copy
Sheets("Prior Years Data").Range("A1:H29998").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Sheet1.Activate
Range("A1:B29998").Select
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
Range("A1:H29998").Sort Key1:=Range("G1"), Order1:=xlDescending, Header:=xlNo
End Sub
I tried creating a concatenated range formula in Excel from calculated Find values, code to copy the first row with only a space in it and copying that down, building a range formula in VBA instead of Excel, and various iterations of those until I gave up on my ability to solve the problem.
you can use AutoFilter() to filter negative values and clear them
here's a possible code, where I also refactored your existing one to add more consistency
Sheets("Barrel List by Producer").Range("AD3:AK17").Copy
With Sheets("Prior Years Data")
.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
With .Range("A1").CurrentRegion
.NumberFormat = "General"
.Value = .Value
.Sort Key1:=.Range("G1"), Order1:=xlDescending, Header:=xlNo
.AutoFilter field:=7, Criteria1:="<0"
With .Resize(.Rows.Count - 1).Offset(1)
If CBool(Application.Subtotal(103, .Columns(1))) Then
.SpecialCells(xlCellTypeVisible).ClearContents
End If
End With
End With
.AutoFilterMode = False
End With
Sub CopyPasteToPrYrData()
'
' CopyPasteToPrYrData Macro
'
' Keyboard Shortcut: Ctrl+Shift+C
'
Sheets("Barrel List by Producer").Range("AD3:AK30000").Copy
Sheets("Prior Years Data").Range("A1:H29998").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Sheet1.Activate
Range("A1:B29998").Select
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
Range("A1:H29998").Sort Key1:=Range("G1"), Order1:=xlDescending, Header:=xlNo
Columns("G:G").Select
Selection.Find(What:="-", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
End Sub
I'm stuck on this, I don't understand why the code adds those extra zeros in column D; What am I doing wrong?
Code: https://pastebin.com/ccpqPJdz
last = Range("B" & Rows.Count).End(xlUp).Row
'Insert 3 columns on left. Add information in Row 1, add data in column D.
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("E:E").Copy Destination:=Columns("C:C")
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Range("D2:D2" & last).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C[6]"
Columns("D").Copy
Columns("D").PasteSpecial xlPasteValues
Range("D1") = Time
Range("D1").NumberFormat = "h:mm:ss"
Input:
Output:
Avoid the Selection object. It's created as a medium of communication between the user and VBA via the screen. VBA has direct access to the Excel workbook and therefore doesn't need it. Please try this code.
Private Sub InsertThreeColumns()
Dim Rl As Long ' last used row
Dim Rng As Range
With Worksheets("NewTest") ' change to suit
Rl = .Cells(.Rows.Count, "B").End(xlUp).Row
.Columns(2).Copy
.Columns(1).Insert Shift:=xlToRight
Application.CutCopyMode = False
.Columns("A:B").Insert Shift:=xlToRight
.Columns(5).EntireColumn.Delete
On Error Resume Next
' next line will cause a crash if there are no blanks
Set Rng = .Range(.Cells(2, "D"), .Cells(Rl, "D")).SpecialCells(xlCellTypeBlanks)
If Err = 0 Then
Rng.FormulaR1C1 = "=R[-1]C[6]"
Rng.Copy
Rng.PasteSpecial xlPasteValues
End If
On Error GoTo 0
With .Cells(1, "D")
.Value = Time
.NumberFormat = "h:mm:ss"
End With
End With
End Sub
The extra zeroes that troubled you were caused by the method of defining the range where you wanted the formula to supply cell content. In your code that range is a derivative of a Selection. In the above code it's defined by starting cell and end cell. The result should be the same. It isn't because the route via the Selection object is circuitous and difficult to follow.
Thank you in advance and sorry for the bad english!
I want
fix100-->current column & last row nummber?
Cells(100, ActiveCell.Column))--->Cells(???, ActiveCell.Column))
Sub ExcelVBA_CurrentValuecu_Filter()
ActiveSheet.Range(Cells(1, ActiveCell.Column), Cells(100, ActiveCell.Column)).AutoFilter Field:=1, Criteria1:=ActiveCell.Value
End Sub
Try this code:
Sub ExcelVBA_CurrentValuecu_Filter()
With ThisWorkbook.ActiveSheet
.Range(.Cells(1, ActiveCell.Column), .Cells(.Rows.Count, ActiveCell.Column).End(xlUp)). _
AutoFilter Field:=1, Criteria1:=ActiveCell.Value
End With
End Sub
The statement .Cells(.Rows.Count, ActiveCell.Column).End(xlUp) will find the last cell in your column that has data in it. I used a With block to properly qualify all the ranges you're using in your code. That's why there's a dot . in front of .Cells. This is the same as always writing ActiveSheet.Cells.
I am new to excel macros and would like to create loop that identified a column range and hopefully a row range to remove duplicates. Currently I have taken the long way around that created an excel formula to create the macro script for the below.
Any help with the below would be much appreciated cause I am now at 60 columns and need to add another 40...
Thank you
Sheets("Result").Select
Columns("A:A").Select
ActiveSheet.Range("$A$1:$A$100000").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("B:B").Select
ActiveSheet.Range("$B$1:$B$100000").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("C:C").Select
ActiveSheet.Range("$C$1:$C$100000").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("D:D").Select
ActiveSheet.Range("$D$1:$D$100000").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("E:E").Select
ActiveSheet.Range("$E$1:$E$100000").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("F:F").Select
ActiveSheet.Range("$F$1:$F$100000").RemoveDuplicates Columns:=1, Header:=xlNo
This will work if you only care about duplicates per column.
Sub RemoveDuplicates()
'Stop the screen from updating to reduce lag
Application.ScreenUpdating = False
'Main loop
For i = 1 To 100
ActiveWorkbook.Sheets("Result").Columns(i).RemoveDuplicates Columns:=1, Header:=xlNo
Next
'Reset ScreenUpdating
Application.ScreenUpdating = True
End Sub
You need a loop!
Sub RemoveDuplicates()
Dim TargetSheet As Worksheet
Set TargetSheet = ActiveWorkbook.Worksheets("Result")
For i = 1 To 100
TargetSheet.Cells(1, i).EntireColumn.RemoveDuplicates Columns:=1, Header:=xlNo
Next i
End Sub
This will perform a column-by-column duplicate removal:
Sub Kleanup()
For i = 1 To Columns.Count
Columns(i).Cells.RemoveDuplicates Columns:=1, Header:=xlNo
Next i
End Sub
Remove Duplicated based on the adjacent cell values, with help of VBA
ID|Status
1234|Not Started - Need to be deleted
1234|Completed
3456|Completed
3456|Completed - Need to be deleted
Given your sample data all you have to do is sort by the second column in a ascending order then use Remove Duplicates.
Option Explicit
Sub sortNdedupe()
With Worksheets("sheet4")
With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp))
.Cells.Sort Key1:=.Columns(2), Order1:=xlAscending, _
Header:=xlYes
.RemoveDuplicates Columns:=1, Header:=xlYes
End With
End With
End Sub
Select which of the two methods do you prefer and try:
Sub Removeduplicates()
Dim Lastrow As Long
With Worksheets("sheet1")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Remove based on based on ID
With .Range("A1" & ":B" & Lastrow)
.Removeduplicates Columns:=1, Header:=xlYes
End With
'Remove based on ID and Status
With .Range("A1" & ":B" & Lastrow)
.Removeduplicates Columns:=Array(1, 2), Header:=xlYes
End With
End With
End Sub