I'm trying to remove duplicate rows in my Excel Sheet using Visual Basic. The problem is that the amount of Rows will be variable.
Sub RemoveDuplicates()
Range("A1").Select
ActiveSheet.Range(Selection, ActiveCell.CurrentRegion).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
End Sub
The problem here is that Columns:=Array(1, 2) isn't a variable. It should always look from column 1 until the last filled column (the .CurrentRegion).
Can someone please help me!
One way is to create the array dynamically.
Once the block has been defined, we know exactly how many columns the block contains:
Sub luxation()
Dim A1 As Range, rng As Range, cCount As Long
Set A1 = Range("A1")
Set rng = A1.CurrentRegion
cCount = rng.Columns.Count - 1
ReDim ary(0 To cCount)
For i = 0 To cCount
ary(i) = i + 1
Next i
rng.RemoveDuplicates Columns:=(ary), Header:=xlYes
End Sub
Note the encapsulation of ary() in the last line!
Gary's Student has the correct answer.
I'm just having a little fun:
Dim a As Variant
With Range("A1").CurrentRegion
a = Evaluate("Transpose(Row(1:" & .Columns.Count & "))")
ReDim Preserve a(0 To UBound(a) - 1)
.RemoveDuplicates Columns:=(a), Header:=xlYes
End With
Maybe you want something like this:
Sub RemoveDuplicates()
Dim LastCol As Long
Dim LastRow As Long
Dim ColArray As Variant
Dim i As Long
' modify "Sheet1" to your sheet's name
With Sheets("Sheet1")
' find last column with data in first row ("header" row)
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
' find last row with data in column "A"
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim ColArray(0 To LastCol - 1)
For i = 0 To UBound(ColArray)
ColArray(i) = i + 1
Next i
.Range(.Cells(1, 1), .Cells(LastRow, LastCol)).RemoveDuplicates Columns:=(ColArray), Header:=xlYes
End With
End Sub
Related
I want to remove duplicated values in my Table. It is ListObject Table with 1000s of lines.
I cannot get to work my code and I am using function RemoveDuplicates for ranges with the condition to delete the lines in the table if there are duplicates in 2 relative columns.
This is how it looks before running the code:
In my code, based on column C:C and E:E only, I need to check if each line has any duplicates within these 2 columns and delete them, leaving only one.
And this is my desired outcome:
This is my code that does not work. I am not sure if it is because my table is the List Object or because I assign Array wrong?
Sub test_Duplicate()
Dim endrow As Long
Dim rng As Range
Dim ws As Worksheet
Set ws = Sheets("Sheet4")
With ws
endrow = .Cells(.Rows.Count, 3).End(xlUp).Row
Set rng = .Range(.Cells(2, 3), .Cells(endrow, 6))
rng.RemoveDuplicates Columns:=Array(1, 3), Header:=xlNo
End With
End Sub
I will appreciate any help.
I noticed that whether my data is in the table as List Object or whether is it without it, I am getting the error nr 9 anyway.
This will work:
Just change the TableName ..Mine is Table1
Sub test_Duplicate()
Dim ws As Worksheet
Set ws = Sheets("Sheet4")
With ws
.Range("Table1[#All]").RemoveDuplicates Columns:=Array(1, 3), Header:=xlYes
End With
End Sub
Table Name is found on the Design Tab when you select the table.
Here is the best solution I managed to find by looking through web.
Sub RemoveDuplicates()
Const TEST_COLUMN As String = "A"
Dim i As Long
Dim iLastRow As Long
Dim rng As Range
Dim ws As Worksheet
Set ws = Worksheets("Sheet4")
With ws
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To iLastRow
If .Evaluate("SUMPRODUCT(--(A" & i & ":A" & iLastRow & "=A" & i & ")," & _
"--(I" & i & ":I" & iLastRow & "=I" & i & "))") > 1 Then
If rng Is Nothing Then
Set rng = .Cells(i, "A").Resize(, 9)
Else
Set rng = Union(rng, .Cells(i, "A").Resize(, 9))
End If
End If
Next i
If Not rng Is Nothing Then rng.Delete
End With
End Sub
I have a code that counts the cell in a range if there's a number. The total number of cell counted will then be shown in row 3. My issue now is that the formula is not variable and I have no idea how to make it too.
If I enter this code, row 3 reports all the same result (which is from the first column of data). Hoping somebody can help me here!!
Sub Six_Continue()
Dim Rng As Range
Dim LastClm As Long
With ActiveSheet
LastClm = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set Rng = Range(.Cells(3, 3), .Cells(3, LastClm))
Rng.Value = Application.WorksheetFunction.CountIf(Range("C5", "C" & Cells(Rows.Count, 5).End(xlUp).Row), "<>?")
End With
End Sub
Your CountIf will count cells even if they don't contain a number. Using Count ensures that only cells containing numbers are taken into account.
Sub Six_Continue()
Dim Rng As Range
Dim LastClm As Long
Dim myClm As Long
With ActiveSheet
LastClm = .Cells(1, .Columns.Count).End(xlToLeft).Column
For myClm = 1 To LastClm
Set Rng = .Cells(3, myClm)
Rng.Value = Application.WorksheetFunction.Count(Range(.Cells(5, myClm), .Cells(.Cells(Rows.Count, myClm).End(xlUp).Row, myClm)))
Next myClm
End With
End Sub
Try this modified version:
Sub Six_Continue()
Dim Rng As Range
Dim LastClm As Long, i As Long
LastClm = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To LastClm
Cells(3, i).Value = Application.WorksheetFunction.CountIf(Range(Cells(1, i), Cells(2, i)), "<>?")
Next
End Sub
I want to create macro for remove duplicate cells from single column and repeat same for rest of the columns.
I have code do this for single column and its working but I am not able to convert this code to repeat same process for rest of the columns.
Can anyone please help me with this?
Sub Delete_Dupes2()
Dim lastrow As Long
Application.ScreenUpdating = False
With Sheet2
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("$A$1:$A$" & lastrow).RemoveDuplicates Columns:=1, Header:=xlYes
End With
Application.ScreenUpdating = True
End Sub
Here for the first 10 columns :
Sub Delete_Dupes3()
Application.ScreenUpdating = False
Dim LastRow As Long
With Sheet2
For j = 1 To 10
LastRow = .Cells(.Rows.Count, j).End(xlUp).Row
.Range(.Cells(1, j), .Cells(LastRow, j)).RemoveDuplicates Columns:=1, _
Header:=xlYes
End If
End With
Application.ScreenUpdating = True
End Sub
BTW, in you screenshot (probably dummy data), there is not headers and yet the argument says the opposite : Header:=xlYes
Another way (R3uK posted while I was testing my answer).
I've added two ways of referencing the range - the first returns the row number, the second returns a reference to the cell.
As both R3uK and myself have put - rather than use .Range("$A$1:$A$" & lastrow) I find it easier to use .Range(.Cells(1, 1), .Cells(lastrow, 1)) as you refer to the column with a number rather than letter designation.
Option Explicit
Sub Test()
Delete_Dupes2 1
Delete_Dupes2 3
Delete_Dupes2 ColumnNum:=5
Dim x As Long
For x = 1 To 10
Delete_Dupes2 ColumnNum:=x
Next x
End Sub
Sub Delete_Dupes2(ColumnNum As Long)
Dim lastrow As Long
Dim lastrow1 As Range
Application.ScreenUpdating = False
With Sheet2
lastrow = .Cells(Rows.Count, ColumnNum).End(xlUp).Row
.Range(.Cells(1, ColumnNum), .Cells(lastrow, ColumnNum)).RemoveDuplicates Columns:=1, Header:=xlYes
'or
'Set lastrow1 = .Cells(Rows.Count, ColumnNum).End(xlUp)
'.Range(.Cells(1, ColumnNum), lastrow1).RemoveDuplicates Columns:=1, Header:=xlYes
End With
Application.ScreenUpdating = True
End Sub
Edit:
Or you could change the procedure name to:
Sub Delete_Dupes2(ColumnNum As Long, wrkSht As Worksheet)
change the With Sheet2 line to:
With wrkSht
change your calling (Test) lines to:
Delete_Dupes2 1, Sheet2
Delete_Dupes2 3, Sheet1
Delete_Dupes2 ColumnNum:=5, wrkSht:=ThisWorkbook.Worksheets("AnotherSheet")
Dim x As Long
For x = 1 To 10
Delete_Dupes2 ColumnNum:=x, wrkSht:=ActiveWorkbook.Worksheets("ASheetInAnotherFile")
Next x
I have found the code
Sub Test()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows,SearchDirection:=xlPrevious).Row
Dim lColumn As Long
Dim x As Long
Dim rng As Range
For Each rng In Range("A1:A" & LastRow)
lColumn = Cells(rng.Row, Columns.Count).End(xlToLeft).Column
For x = 1 To lColumn - 2
Range(Cells(rng.Row, "A"), Cells(rng.Row, "B")).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rng.Offset(0, x + 1)
Next x
Next rng
Application.ScreenUpdating = True
End Sub
I am trying to modify it to suit my needs but it isn't quite doing what I need it to do.
Basically, my table is like this:
A B C D
FILENAME ID FIELD1 FIELD2
1 2 3 4
and I want it to look like this:
A FILENAME 1
B ID 2
C FIELD1 3
D FIELD2 4
however, sometimes there may be more columns or rows associated with a given part of the range that is related to a set of data. right now the columns that
I don't know nearly enough about excel and vba to modify this code to do that, but it would be nice if I could.
below are a couple of links that explain closely how I want the final table to look.
http://pastebin.com/1i5MqTL7
http://imgur.com/a/PKAcy
The ID's are not unique product pointers, but that's the REAL world. Different considerations and assumptions about the consistency of your input data, but try this:
Private Sub TransposeBits()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'start will be the starting row of each set
Dim start As Long
start = 2
'finish will be the last row of each set
Dim finish As Long
finish = start
Dim lastRow As Long
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'printRow will keep track of where to paste-transpose each set
Dim printRow As Long
printRow = lastRow + 2
'lastCol will measure the column count of each set
Dim lastCol As Long
'Just dealing with a single entry here - delete as necessary
If lastRow < 3 Then
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
'in the trivial case, we can exit the sub after dealing with the one-line transpose
Exit Sub
End If
'more general case
For i = 3 To lastRow
If Not Range("A" & i).Value = Range("A" & i - 1).Value Then
'the value is different than above, so set the finish to the above row
finish = i - 1
lastCol = Cells(start, 1).End(xlToRight).Column
'copy the range from start row to finish row and paste-transpose
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
'after finding the end of a set, reset the start and printRow variable
start = i
printRow = printRow + lastCol
End If
Next i
'here we deal with the last set after running through the loop
finish = lastRow
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
End Sub
You can use the Paste Special that #Jeeped uses - just write it in code:
Sub TransposeData()
Dim rLastCell As Range
With ThisWorkbook.Worksheets("Sheet1")
'NB: If the sheet is empty this will throw an error.
Set rLastCell = .Cells.Find("*", SearchDirection:=xlPrevious)
'Copy everything from A1 to the last cell.
.Range(.Cells(1, 1), rLastCell).Copy
'Paste/Transpose in column A, one row below last row containing data.
.Cells(rLastCell.Row + 1, 1).PasteSpecial Transpose:=True
End With
End Sub
I have a worksheet ("Data") with x-columns and y-rows. I want to concatenate the values of a row and the concatenated result should be copied to a second worksheet ("Insert") in the first column of the same row.
I tried this VBA and get an error message
Sub InsertStatementRow()
Dim x As String, rng As Range, rng1 As Range, cel As Range
Dim ColMax As Integer
Dim i As Long
Sheets("Data").Select
Range("A1").Select
ColMax = Cells(1, Columns.Count).End(xlToLeft).Column
With Worksheets("Data")
i = 1
Set rng = Range(Cells(i, 1), Cells(i, ColMax))
End With
For Each cel In rng
x = x & cel.Value
Next
Range(Sheets("Insert").Cells(i, 1)).Value = x
End Sub
Please show me what I am doing wrong by correcting my code. Thanks!
Use some "." :
Set rng = Range(.Cells(i, 1), .Cells(i, ColMax))