Move duplicates rows above - excel

I have sheet1 and sheet10 to run a macro to find duplicates comparing column A and B.
Highlight color duplicates, in column A, move duplicates to first row A1.
Any help will appreciate, thank you in advance.
Macro need to run in sheet 1 and sheet 10 maybe less sheets.
Sub sbFindDuplicatesInColumn()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A1:C").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
Cells(iCntr, 2) = "Duplicate"
End If
End If
Next
End Sub

Build a range of the duplicate cells using Union, copy and insert them in the first row and then delete them.
Sub sbFindDuplicatesInColumn2()
Const DUP_COLOR = &H9696FF ' pink
Dim ws, rngDup As Range, c As Range
Dim arC, v, sht, lastRow As Long, n As Long
For Each sht In Array("Sheet1", "Sheet10")
Set ws = Sheets(sht)
n = 0
With ws
.Cells.ClearFormats
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
arC = .Range("C1:C" & lastRow) ' array
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each c In .Range("A1:A" & lastRow)
v = Application.Match(c.Value2, arC, 0)
If Not IsError(v) Then
.Cells(v, "C").Interior.Color = DUP_COLOR
If n = 0 Then
Set rngDup = c
Else
Set rngDup = Application.Union(rngDup, c)
End If
n = n + 1
End If
Next
' move cells and sort
If n > 0 Then
' copy to top
.Range("A1").Resize(n).Insert shift:=xlDown
rngDup.Copy .Range("A1")
.Range("A1:A" & n).Interior.Color = DUP_COLOR
' delete
rngDup.Delete shift:=xlUp
' sort
With .Sort
.SetRange ws.Range("A1:A" & n)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End With
MsgBox n & " Duplicates found in " & ws.Name, vbInformation
Next
End Sub

You should add comparing the values of ranges
Sub sbFindDuplicatesInColumn()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A1:C").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 AND Cells(iCntr,1).Value <> Range("A1:A" & lastRow).Value
Then
Cells(iCntr, 2) = "Duplicate"
End If
End If
Next
End Sub

Related

How to expend the code to transfer data from one spreadsheet to another based on multiple criteria

I have a very large Excel file from which I transfer complete rows (not copy but cut) to another spreadsheet based on certain criteria.The searched criteria are not only names (string), it can also be numbers that start with e.g. 45*. My created code works fine for smaller files, but for larger ones it just takes too long, sometimes it even crashes.
I would like to extend the code with more functions:
Delete all existing tables except the main table.
Search for several criteria (e.g. "Government", "Midmarket", "45", "Enterprise") that can occur in column "S" and create a new table for each criterion which were found in column "S" and transfer the complet row in a new sheet. The name of the new sheet should be the name of defined criterion.
Show the progress via a status or progress bar.
Here is the code I currently use:
Sub VTest()
Dim LastRow As Long
Dim CurrentRow As Long
Dim SourceSheetName As String
SourceSheetName = "InstallBase" ' <--- Set this to name of the Source sheet
Application.ScreenUpdating = False ' Turn ScreenUpdating off to prevent screen flicker
Sheets.Add after:=Sheets(SourceSheetName) ' Add a new sheet after the Source sheet
ActiveSheet.Name = "Midmarket" ' Assign a name to newly created sheet
Sheets(SourceSheetName).Range("A1:AC1").Copy Sheets("Midmarket").Range("A1:AC1") ' Copy Header rows from Source sheet to the new sheet
LastRow = Sheets(SourceSheetName).Range("A" & Rows.Count).End(xlUp).Row ' Determine Last used row in column A
For CurrentRow = LastRow To 2 Step -1 ' Start at LastRow and work backwards, row by row, until beginning of data
If Sheets(SourceSheetName).Range("S" & CurrentRow).Value Like "Midmarket" Then ' If we encounter a 'Yes' in column S then copy the row to new sheet
Sheets(SourceSheetName).Rows(CurrentRow).Copy Sheets("Midmarket").Range("A" & Rows.Count).End(xlUp).Offset(1)
Sheets(SourceSheetName).Rows(CurrentRow).Delete ' Delete the row from the Source sheet that contained 'Yes' in column S
End If
Next ' Continue checking previous row
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
End Sub
The status or progress bar can look like this:
This should only take seconds so the progress bar is unnecessary.
Sub VTest2()
Const COL_FILTER = 19 ' S
Const HDR = "A1:AC1"
Dim wb As Workbook, wsSrc As Worksheet, ws As Worksheet
Dim rng As Range, rng1 As Range
Dim arCrit, i As Long, lastrow As Long, lastCol As Long
Dim s As String, grp As String
Dim r1 As Long, r2 As Long, rCopy As Long
Dim t0 As Single
arCrit = Array("Northmarket", "Midmarket", "Southmarket", "inside", "outside", "123*")
Dim group As Object
Set group = CreateObject("Scripting.Dictionary")
With group
.Add "Northmarket", "Market"
.Add "Southmarket", "Market"
.Add "Midmarket", "Market"
.Add "outside", "InOutSide"
.Add "inside", "InOutSide"
End With
Set wb = ThisWorkbook
Set wsSrc = wb.Sheets("InstallBase")
Call CreateTestData(wsSrc, 10000, arCrit, COL_FILTER)
' Delete all existing tables except the main table.
t0 = Timer
Application.DisplayAlerts = False
For Each ws In wb.Sheets
If ws.Name <> wsSrc.Name Then
ws.Delete
End If
Next
Application.DisplayAlerts = True
' sort
Application.ScreenUpdating = False
With wsSrc
lastrow = .Cells(.Rows.Count, COL_FILTER).End(xlUp).Row
lastCol = .UsedRange.Columns.Count
' add row counter to preserve order
For i = 1 To lastrow
.Cells(i, lastCol + 1) = i
Next
With .Sort
.SortFields.Clear
.SortFields.Add2 Key:=wsSrc.Cells(1, COL_FILTER), _
SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
.SetRange wsSrc.UsedRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
' loop criteria
For i = LBound(arCrit) To UBound(arCrit)
s = arCrit(i)
' use aggregate name for sheet if one
If group.exists(s) Then
grp = group(s)
Else
grp = s
End If
On Error Resume Next
Set ws = wb.Sheets(grp)
On Error GoTo 0
' create sheet or clear existing
If ws Is Nothing Then
Set ws = wb.Sheets.Add(after:=wsSrc)
ws.Name = Replace(grp, "*", "~")
wsSrc.Range(HDR).Copy ws.Range("A1")
End If
rCopy = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
' find first match
Set rng = wsSrc.Columns(COL_FILTER).Find(s, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
Else
r1 = rng.Row ' first
' find last
Do While rng.Offset(1) Like s
Set rng = rng.Offset(1)
Loop
r2 = rng.Row
Set rng = wsSrc.Range(HDR).Offset(r1 - 1).Resize(r2 - r1 + 1)
Debug.Print s, r1, r2, r2 - r1, rng.Address
rng.Copy ws.Range("A" & rCopy)
rCopy = rCopy + rng.Rows.Count
rng.EntireRow.Delete
End If
Set ws = Nothing
Next
' restore order
With wsSrc
With .Sort
.SortFields.Clear
.SortFields.Add2 Key:=wsSrc.Cells(1, lastCol + 1), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange wsSrc.UsedRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Columns(lastCol + 1).Delete
End With
Application.ScreenUpdating = True
MsgBox wb.Sheets.Count - 1 & " sheets created", vbInformation, "Took " & Format(Timer - t0, "0.0 secs")
End Sub
Sub CreateTestData(ws, n, ar, c)
Dim i As Long, j As Long, x, t0 As Single
t0 = Timer
ReDim x(1 To n, 1 To 29)
For j = 1 To 29 'AC
x(1, j) = "Header " & j
Next
For i = 2 To n
For j = 1 To 29 'AC
x(i, j) = Split(Cells(i, j).Address(0, 0, xlA1), ":")(0)
Next
' 50% other data
If Int(Rnd * 2) = 1 Then
x(i, c) = Replace(ar(Rnd * UBound(ar)), "*", "")
If IsNumeric(x(i, c)) Then
x(i, c) = x(i, c) & Format(10000 * Rnd, "00000")
End If
Else
x(i, c) = "Other data"
End If
Next
'Application.ScreenUpdating = False
With ws
.Cells.Clear
.Range("A1").Resize(n, 29) = x
End With
'Application.ScreenUpdating = True
MsgBox i - 1 & " rows of test data created", vbInformation, _
"Took " & Format(Timer - t0, "0.0 secs")
End Sub

Clear adjacent duplicates only

This sub clears duplicate rows between two columns.
If it finds a new pair in columns F & G, it will clear that pair throughout F & G.
I'm trying to clear values that are directly below the original values.
I'm trying to reset after a duplicate been cleared, so that it doesn't clear values that aren't directly below the original values.
Sub clearDups1()
Dim lngMyRow As Long
Dim lngMyCol As Long
Dim lngLastRow As Long
Dim objMyUniqueData As Object
Application.ScreenUpdating = False
lngLastRow = Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
Set objMyUniqueData = CreateObject("Scripting.Dictionary")
For lngMyRow = 1 To lngLastRow 'Assumes the data starts at row 1. Change to suit if necessary.
If objMyUniqueData.Exists(CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7))) = False Then
objMyUniqueData.Add CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7)), Cells(lngMyRow, 6) & Cells(lngMyRow, 7)
Else
Range(Cells(lngMyRow, 6), Cells(lngMyRow, 7)).ClearContents
End If
Next lngMyRow
Set objMyUniqueData = Nothing
Application.ScreenUpdating = True
End Sub
Any input appreciated.
You don't need a dictionary for this:
Sub clearDups1()
Dim lngMyRow As Long, lngLastRow As Long, ws As Worksheet
Dim k As String, kPrev As String
Set ws = ActiveSheet
lngLastRow = ws.Range("F:G").Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).row
Application.ScreenUpdating = False
kPrev = Chr(0) 'won't occur in your data
For lngMyRow = 1 To lngLastRow 'Assumes the data starts at row 1. Change to suit if necessary.
k = CStr(ws.Cells(lngMyRow, 6).Value) & "<>" & CStr(ws.Cells(lngMyRow, 7).Value)
If kCurr = k Then 'same as previous row?
ws.Cells(lngMyRow, 6).Resize(1, 2).ClearContents
End If
kPrev = k 'set as key for previous row
Next lngMyRow
Application.ScreenUpdating = True
End Sub
You can also try this code. It does what you have asked.
Leave the first occurring of the same dups
Start from the bottom to delete them and leave the final which in our case will be original
Using the above ways you can achieve what you have asked for.
Sub clearDups()
Dim lR As Long, r As Long
Dim x As 99999
Dim f(x), g(x) As String
Dim lRow As Long, lCol As Long, i As Long
lRow = Range("F" & Rows.Count).End(xlUp).Row
For lR = 2 To lRow
f(lR - 1) = Cells(lR, "F").Value
g(lR - 1) = Cells(lR, "G").Value
Next
For Each s In f
i = i + 1
If Application.CountIf(Range("F1:G" & lRow), s) = 2 Then
Cells(i, "F").Value = ""
Cells(i, "G").Value = ""
End If
Next
End Sub

How to combine or merge cells with the same values vertically and horizontally , Excel VBA?

I have sheet with same data in adjacent cells,I could to merge same cells on column A.
now I need to merge or combine adjacent same cells beside merged cells on column A , meaning if A2:A3 is same that will be merged and subsequently merge B2:B3 ,C2:C3, D2:D3 until column L.
Update: any method other than Merge will be good also
Sub Merge_Similar_Cells()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim LastRow As Long
Dim ws As Worksheet
Dim WorkRng As Range
Set ws = ActiveSheet
ws.AutoFilter.ShowAllData
ws.AutoFilter.Sort.SortFields.Clear
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ws.AutoFilter.Sort.Apply
Set WorkRng = ws.Range("A2:A" & LastRow)
CheckAgain:
For Each cell In WorkRng
If cell.Value = cell.Offset(1, 0).Value And Not IsEmpty(cell) Then
Range(cell, cell.Offset(1, 0)).Merge
cell.VerticalAlignment = xlCenter
GoTo CheckAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Please, test the next code:
Sub Merge_Similar_Cells()
Dim LastRow As Long, ws As Worksheet, arrWork, i As Long, j As Long, k As Long
Set ws = ActiveSheet
If ws.AutoFilterMode Then 'for the case when the sheet range is not filtered
ws.AutoFilter.ShowAllData
ws.AutoFilter.Sort.SortFields.Clear
End If
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ws.AutoFilter.Sort.Apply
arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
Application.DisplayAlerts = False: Application.ScreenUpdating = False
For i = 2 To UBound(arrWork) - 1 'iterate between the array elements:
If arrWork(i, 1) = arrWork(i + 1, 1) Then
'determine how many consecutive similar rows exist:_________
For k = 1 To LastRow
If i + k + 1 >= UBound(arrWork) Then Exit For
If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
Next k '____________________________________________________
For j = 1 To 12
ws.Range(ws.Cells(i, j), ws.Cells(i + k, j)).Merge 'merge all the necessary cells based on previously determined k
Next j
ws.Range(ws.Cells(i, 1), ws.Cells(i + k, 12)).VerticalAlignment = xlCenter 'apply vertical alignment for all obtained merged row
i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
End If
Next i
Application.DisplayAlerts = True: Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Edited:
Please, try the next code, which does not merge similar rows on identic column. It delete the similar rows, keeping only one and append the cells values in the range "M:P", separated by vbLf (placing on a separate row in the same cell):
Sub DeleteSimilarRows_AppendLastColuns()
Dim LastRow As Long, ws As Worksheet, arrWork, rngDel As Range, i As Long, j As Long, k As Long
Dim strVal As String, m As Long, boolNoFilter As Boolean
Set ws = ActiveSheet
If ws.AutoFilterMode Then 'for the case when the sheet range is not filtered
ws.AutoFilter.ShowAllData
ws.AutoFilter.Sort.SortFields.Clear
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row: boolNoFilter = True
ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ws.AutoFilter.Sort.Apply
End If
If Not boolNoFilter Then LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
Application.DisplayAlerts = False: Application.ScreenUpdating = False
For i = 2 To UBound(arrWork) - 1 'iterate between the array elements:
If arrWork(i, 1) = arrWork(i + 1, 1) Then
'determine how many consecutive similar rows exist:______
For k = 1 To LastRow
If i + k + 1 >= UBound(arrWork) Then Exit For
If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
Next k '_________________________________________
For j = 13 To 16 'build the concatenated string of cells in range "M:P":
strVal = ws.Cells(i, j).Value
For m = 1 To k
strVal = strVal & vbLf & ws.Cells(i + m, j).Value
Next m
ws.Cells(i, j).Value = strVal: strVal = ""
Next j
For m = 1 To k 'place the cells for rows to be deleted in a Union range, to delete at the end, at once
If rngDel Is Nothing Then
Set rngDel = ws.Range("A" & i + m)
Else
Set rngDel = Union(rngDel, ws.Range("A" & i + m))
End If
Next m
i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete 'delete the not necessary rows
ws.UsedRange.EntireRow.AutoFit: ws.UsedRange.EntireColumn.AutoFit
Application.DisplayAlerts = True: Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub

Insert Row when 2 conditions are met

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

how to create array with number of columns in sheet dynamically,for remove duplicates in multiple columns

i am new to vba,here i am explaining my situation
1,i want know how to form array in vba with index 1
2,How to give array to remove duplicates**
i want give remove multiple columns in sheet,dynamically i mean if sheet contain 5 rows i want to give
(1,2,3,4,5)
if sheet contain 3--(1,2,3)
here my code:
Dim darray() As Integer
For i = 1 To LastCol1
ReDim Preserve darray(i)
darray(i) = i
Next i
wsDest.Range("A1" & ":" & Cells(LastRow1, LastCol1).Address).RemoveDuplicates Columns:=(darray), Header:=xlYes
wsDest.Range("A1" & ":" & Cells(LastRow1, LastCol1).Address).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
with this code i am get error : invalid procedure call oenter code herer argument
below code is to conscile data from all files in folder and sort data and remove duplicates finally want to create pivot table
Sub LoopAllFilesInAFolder()
Dim FolderPath As String
Dim Filename As String
Dim lDestLastRow As Long
FolderPath = "D:\surekha_intern\vba macro learning\assignment\students_data_a3\"
Set wsDest = Workbooks("VBA_A3.xlsm").Worksheets("sheet1")
Filename = Dir(FolderPath)
While Filename <> ""
'Debug.Print Filename
'Workbooks.Open Filename:=FolderPath & Filename
Set wb = Workbooks.Open(FolderPath & Filename)
If WorksheetFunction.CountA(ActiveSheet.UsedRange) = 0 And ActiveSheet.Shapes.Count = 0 Then
Debug.Print Filename; " is empty"
Else
Dim LastRow As Long
Dim Lastrow_te As Long
With wb.Sheets(1)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'down
Lastrow_te = .Range("A99999").End(xlUp).Row
'Rows.Count, "A"
MsgBox Lastrow_te
End With
Dim LastCol As Integer
With wb.Sheets(1)
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
' MsgBox LastCol
End With
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(0).Row
' MsgBox lDestLastRow
'Range("a1:a10").Copy
'Range("a1:a10").PasteSpecial
'Application.CutCopyMode = False
If lDestLastRow = 1 Then
'MsgBox "HI" '.Range("A" & LastRow & LastCol)'"A" & lastRow & ":" & Cells(lastRow, lastCol).Address
wb.Sheets("Sheet1").Range("A1" & ":" & Cells(LastRow, LastCol).Address).Copy '"A" & LastRow & LastCol ----"A" & LastRow, LastCol
wsDest.Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Else
wb.Sheets("Sheet1").Range("B1" & ":" & Cells(LastRow, LastCol).Address).Copy
Workbooks("VBA_A3.xlsm").Sheets("sheet1").Range("A" & lDestLastRow + 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
'MsgBox wsDest.Range("A" & lDestLastRow)
'wb.Sheets("Sheet1").Range("A" & LastRow & LastCol).Copy Destination:=wsDest.Range(A & lDestLastRow)
End If
End If
' ActiveSheet.Close
wb.Close False
Filename = Dir
Wend
Workbooks("VBA_A3.xlsm").Save
Dim LastRow1 As Long
With wsDest
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row 'down
'Rows.Count, "A"
' MsgBox LastRow
End With
Dim LastCol1 As Integer
With wsDest
LastCol1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
' MsgBox LastCol
End With
'SORTING
With wsDest.Sort
.SortFields.Add Key:=Range("A1:A" & LastRow), Order:=xlAscending
.SetRange Range("A1" & ":" & Cells(LastRow1, LastCol1).Address)
.Header = xlYes
.Apply
End With
'duplicates remove
' Dim darray() As Integer
'For i = 1 To LastCol1
' ReDim Preserve darray(i)
' darray(i) = i
' Next i
'MsgBox darray()
'wsDest.Range("A1" & ":" & Cells(LastRow1, LastCol1).Address).RemoveDuplicates Columns:=(darray), Header:=xlYes
'ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
'TEXT EFFECTS
Dim colm As String
Select Case LastCol1
Case 1
colm = "a1"
Case 2
colm = "b1"
Case 3
colm = "c1"
Case 4
colm = "d1"
Case 5
colm = "e1"
End Select
wsDest.Range("a1:" & colm).Interior.ColorIndex = 5
wsDest.Range("a1:" & colm).Font.Bold = True
wsDest.Range("a1:" & colm).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous
wsDest.Range("a1:" & colm).Font.Size = 15
'CREATE PIVOT
'Sheets.Add
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Sheet1!R1C1:R39C4", Version:=xlPivotTableVersion12).CreatePivotTable _
TableDestination:="Sheet6!R3C1", TableName:="PivotTable2", DefaultVersion _
:=xlPivotTableVersion12
Sheets("Sheet6").Select
Cells(3, 1).Select
ActiveWorkbook.ShowPivotTableFieldList = True
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Subject")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
"PivotTable2").PivotFields("marks"), "Sum of marks", xlSum
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Student name")
.Orientation = xlPageField
.Position = 1
End With
MsgBox "Process done"
End Sub
thanks n advance,
Using an Array for Removing Duplicates
The Three Conditions
The array has to be declared as Variant (as you didn't).
The array has to be zero-based (as you didn't).
The array has to be evaluated using Evaluate or () (as you did).
Also
Referencing the range can be simplified.
Always qualify your ranges e.g. wsDest.Cells..., wsDest.Range...
Hardly Related
If you plan to apply RemoveDuplicates to only some of the columns, then using VBA with the Array function will ensure a zero-based array (Option Base related) e.g. dArray = VBA.Array(1, 3, 4).
A Quick Fix
Sub removeDupes()
Dim darray() As Variant: ReDim darray(0 To LastCol1 - 1)
For i = 0 To LastCol1 - 1
darray(i) = i + 1
Next i
wsDest.Range("A1", wsDest.Cells(LastRow1, LastCol1)) _
.RemoveDuplicates Columns:=(darray), Header:=xlYes
End Sub
Another Example
Add a new workbook. Add a module. Copy the code to the module. In Sheet1 create a table (means headers, not necessarily an Excel Table), starting in A1, with 5 rows and 4 columns. Use the same data in 2 or more rows (the same for all columns), run the following procedure and see how only one of 'same-data' rows remains. It also includes an optional 'loop handling'.
Option Explicit
Sub removeDupes()
Dim LastRow1 As Long: LastRow1 = 5
Dim LastCol1 As Long: LastCol1 = 4
Dim arr As Variant: ReDim arr(0 To LastCol1 - 1)
Dim i As Long
For i = 1 To LastCol1
arr(i - 1) = i
Next i
Sheet1.Range("A1", Sheet1.Cells(LastRow1, LastCol1)) _
.RemoveDuplicates Columns:=(arr), Header:=xlYes
End Sub
Try the next code, please. It assumes that the first row is relevant to calculate the existing number of columns:
Sub testRemoveDupl()
Dim wsDest As Worksheet, LastCol1 As Long, lastRow1 As Long, darray()
Set wsDest = ActiveSheet 'use here your necessary sheet!
LastCol1 = wsDest.cells(1, wsDest.Columns.count).End(xlToLeft).Column
lastRow1 = wsDest.Range("A" & wsDest.rows.count).End(xlUp).row
darray = Evaluate("TRANSPOSE(ROW(1:" & LastCol1 & "))")
wsDest.Range("A1", wsDest.cells(lastRow1, LastCol1)).RemoveDuplicates Columns:=Evaluate(darray), Header:=xlYes
'wsDest.Range("A1", wsDest.cells(lastRow1, LastCol1)).RemoveDuplicates Columns:=(darray), Header:=xlYes 'it works in this way, too
End Sub
The problem looks to belong to RemoveDuplicates method. It, theoretically should accept an array without any workaround, but it doesn't... It seems to expect an array of variants, not accepting a single variant containing the array, which is not exactly according to the way the method is documented. It is a known problem of this method since some years...

Resources