I want to find duplicates in two separate columns and extract only those that have duplicates in both of these columns to another worksheet. I want to compare these columns to themselves and find duplicates within the same column. Any advice about how to go about this.
One column contains currency and another contains text. I added apicture for clarification,but this is is what I have tried so far:
Sub match()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range
Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")
With wstSource
Set rngMyData = .Range("A1:AC" & .Range("T" & .Rows.Count) & .Range(Left("N", 4) & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
With helperRng
.FormulaR1C1 = "=if(countif(C20,RC20)>1,"""",1)"
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(2, 1)
.ClearContents
End With
End Sub
Related
I have the macro below runs (no errors) but no results are provided. I have an excel book where duplicates are sometimes found in column "E". Those identified as duplicates should be copied to sheet 2. I know my workbook has duplicates in column E, their just not being copied over.
Sub FilterAndCopy()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range
Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")
Application.ScreenUpdating = False
With wstSource
Set rngMyData = .Range("a1:R" & .Range("a" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
With helperRng
.FormulaR1C1 = "=if(countif(c1,RC1)>1,"""",1)"
.Value = .Value
If Evaluate("=COUNTBLANK(" & .Address & ")") > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(2, 1)
.ClearContents
End With
Application.ScreenUpdating = True
End Sub
Because of the cell notation you are using R1C1, your formula
.FormulaR1C1 = "=if(countif(c1,RC1)>1,"""",1)"
refers only to column A
If you want to change your formula to apply on column E, that would be
.FormulaR1C1 = "=if(countif(c5,RC5)>1,"""",1)"
I don't know if your dupplicates are on a single column basis or if should concatenate all your column to see if the entire row is a dupplicate. It might be more simple to apply a sql query connection on this. Pivot tables may also help. If you stick to vba, add additional line for each dupplicate formula and process it in the block of code that copy blank formula to the secondary sheet.
I have a data set with columns from A to AZ. I want to find if any cell value in Columns A & B is found in Columns AA:AZ and I want a list of those unique not found values from all the compared columns.
What I did first is create 2 new sheets to separate the comparison. 1st sheet (SKUReference) which is copied from column A & B. Second sheet is (SKUNewList) which is copied from AA till AZ. I created a 3rd sheet (NotFoundSKU) to have the desired output which is the Not Found values from the comparison.
The data in the 1st sheet (SKUReference) looks like below :
The data in the 2nd sheet (SKUNewList) looks like below :
The issue I'm facing is : 1- the code isn't finding the Mismatches. 2- It's not storing the unique mismatches correctly. 3- It's not generating those mismatches in the 3rd sheet (NotFoundSKU).
Sub yg23iwyg()
Dim wst As Worksheet
Dim wet As Worksheet
Set wst = Worksheets.Add
Set wet = Worksheets.Add
Set wrt = Worksheets.Add
wst.Name = "SKUReference"
wet.Name = "SKUNewList"
wrt.Name = "NotFoundSKU"
With Worksheets("Sheet1")
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Copy _
Destination:=wst.Cells(1, "A")
.Range(.Cells(1, "AA"), .Cells(.Rows.Count, "AZ").End(xlUp)).Copy _
Destination:=wet.Cells(1, "A")
'alternate with Union'ed range - becomes a Copy, Paste Special, Values and Formats because of the union
.Range("AA:AZ").Copy _
Destination:=wet.Cells(1, "A")
End With
Dim wksMaster As Worksheet, wksSearch As Worksheet
Dim rngMaster As Range, rngSearch As Range
Set wksMaster = Sheets("SKUReference")
Set wksSearch = Sheets("SKUNewList")
With wksMaster
Set rngMaster = .Range("A1:B100" & .Range("A1").SpecialCells(xlCellTypeLastCell).Row)
End With
With wksSearch
Set rngSearch = .Range("A1:Y100" & .Range("A1").SpecialCells(xlCellTypeLastCell).Row)
End With
With rngMaster
For Each cll In rngSearch
Set c = .Find(cll.Value2, LookIn:=xlValues)
If c Is Nothing Then
'MsgBox cll.Value2 & " not found in the SKU Reference List."
Sheets("NotFoundSKU").Range("A1") = cll.Value2
End If
Next
End With
End Sub
Try this, which incorporates comments above (to set rngMaster and rngSearch) and will list values not found in a list going down by finding the first empty cell.
Sub yg23iwyg()
Dim wst As Worksheet
Dim wet As Worksheet, c as range, cll as range
Set wst = Worksheets.Add
Set wet = Worksheets.Add
Set wrt = Worksheets.Add
wst.Name = "SKUReference"
wet.Name = "SKUNewList"
wrt.Name = "NotFoundSKU"
With Worksheets("Sheet1")
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Copy _
Destination:=wst.Cells(1, "A")
.Range(.Cells(1, "AA"), .Cells(.Rows.Count, "AZ").End(xlUp)).Copy _
Destination:=wet.Cells(1, "A")
'alternate with Union'ed range - becomes a Copy, Paste Special, Values and Formats because of the union
.Range("AA:AZ").Copy _
Destination:=wet.Cells(1, "A")
End With
Dim wksMaster As Worksheet, wksSearch As Worksheet
Dim rngMaster As Range, rngSearch As Range
Set wksMaster = Sheets("SKUReference")
Set wksSearch = Sheets("SKUNewList")
With wksMaster
Set rngMaster = .Range("A1:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
End With
With wksSearch
Set rngSearch = .Range("A1:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
End With
With rngMaster
For Each cll In rngSearch
Set c = .Find(cll.Value2, LookIn:=xlValues) 'i would consider adding more parameters here
If c Is Nothing Then
Sheets("NotFoundSKU").Range("A" & Rows.Count).End(xlUp)(2).Value = cll.Value2
End If
Next
End With
End Sub
I'm trying to do the following tasks.
Create X-amount of new sheets in DestWorkbook based on row numbers in the Insert_Data_Sheet table. I've solved this
Rename the sheet according to the D-Column data starting from "D2". So I would like to to rename the first sheet "1865727" and the second sheet "1872188" etc. I've solved this
Store the data in D-column in a seperate variables. No luck with this yet
Here is pictures of the data:
https://pasteboard.co/HABwijq.jpg
https://pasteboard.co/HABwEhE.jpg
Full Code:
Public Sub TermSwap()
Application.ScreenUpdating = False
Dim DestWorkbook As Workbook, AC_Live_Workbook As Workbook, AC_Maturity_Workbook As Workbook
Dim Insert_Data_Sheet As Worksheet, AC_Live_Sheet As Worksheet, AC_Maturity_Sheet As Worksheet, Booked_Sheet As Worksheet
Dim i As Long, d As Long, lastRowA_AC_Live As Long, lastRow_AC_Maturity As Long, NumberOfPages As Long
'Dim Swap_Link_Tid As Long
'I will use these in the end when importing the AC Reports
'AC_Live_Filename = Application.GetOpenFilename(, , "AVAA AC LIVE RAPORTTI")
'AC_Maturity_Filename = Application.GetOpenFilename(, , "AVAA AC MATURITY RAPORTTI")
'Insert filename from above lines as a parameter in the end
Set DestWorkbook = Workbooks("TermSwap")
Set AC_Live_Workbook = Workbooks.Open(FileName:="C:\Users\z000479\Desktop\Makrot\Term Swap makro\Harjoitustiedostot\ALL_COLUMNS_FI_180817.xlsx")
Set AC_Maturity_Workbook = Workbooks.Open(FileName:="C:\Users\z000479\Desktop\Makrot\Term Swap makro\Harjoitustiedostot\ALL_COLUMNS_FI_180820.xlsx")
Set Insert_Data_Sheet = DestWorkbook.Sheets("Insert_Data")
Set Booked_Sheet = DestWorkbook.Sheets("booked")
Set AC_Live_Sheet = AC_Live_Workbook.Sheets("Result")
Set AC_Maturity_Sheet = AC_Maturity_Workbook.Sheets("Result")
'Finds the last row in A-Column in the AC_Live_Sheet and AC_Maturity_Sheet
lastRow_AC_Live = AC_Live_Sheet.Cells(AC_Live_Sheet.Rows.Count, "A").End(xlUp).Row
lastRow_AC_Maturity = AC_Maturity_Sheet.Cells(AC_Maturity_Sheet.Rows.Count, "A").End(xlUp).Row
'Create X-amount of new sheets in DestWorkbook based on row numbers in the Insert_Data_Sheet table.SOLVED
' Rename the sheet according to the D-Column data starting from "D2". SOLVED
' Store the data in D-column in a seperate variables. UNSOLVED
NumberOfPages = Insert_Data_Sheet.Cells((Insert_Data_Sheet.Rows.Count), "A").End(xlUp).Row - 1
Dim target_range As String
For d = 2 To NumberOfPages + 1
target_range = Insert_Data_Sheet.Range("D" & d).Value
DestWorkbook.Worksheets.Add(After:=DestWorkbook.Worksheets(DestWorkbook.Worksheets.Count)).Name = target_range
Next d
' AC LIVE Starts here:
' Show all cells
If AC_Live_Sheet.FilterMode Then
AC_Live_Sheet.ShowAllData
End If
'Delete row 2
AC_Live_Sheet.Range("2:2").Delete
'Autofiter ON. Filters LIVE_DEAL and SWAP_LINK_TID. Change SWAP_LINK_TID to a variable.
'Range syntax here is Range ("$A$1:$DS$" & lastRow)
If Not AC_Live_Sheet.AutoFilterMode Then
AC_Live_Sheet.Range("A1").AutoFilter
AC_Live_Sheet.Range("$A$1:$DS$" & lastRow_AC_Live).AutoFilter Field:=1, Criteria1:= _
"LIVE_DEAL"
AC_Live_Sheet.Range("$A$1:$DS$" & lastRow_AC_Live).AutoFilter Field:=7, Criteria1:= _
"1889087"
End If
'Copy pastes visible cells to Booked_Sheet("A1")
With AC_Live_Sheet
.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Booked_Sheet.Cells(1, 1)
End With
' AC_MATURITY starts here
' Show all cells
If AC_Maturity_Sheet.FilterMode Then
AC_Maturity_Sheet.ShowAllData
End If
'Delete row 2
AC_Maturity_Sheet.Range("2:2").Delete
'Autofiter ON. Filters LIVE_DEAL and SWAP_LINK_TID.
'Range syntax here is Range ("$A$1:$DS$" & lastRow)
'I need to change SWAP_LINK_TID to a variable
If Not AC_Maturity_Sheet.AutoFilterMode Then
AC_Maturity_Sheet.Range("A1").AutoFilter
AC_Maturity_Sheet.Range("$A$1:$DS$" & lastRow_AC_Maturity).AutoFilter Field:=1, Criteria1:= _
"LIVE_DEAL", Operator:=xlOr, Criteria2:="=MAT_DEAL"
AC_Maturity_Sheet.Range("$A$1:$DS$" & lastRow_AC_Maturity).AutoFilter Field:=7, Criteria1:= _
"1889087"
End If
'Copy pastes visible cells to Booked_Sheet("A1")
With AC_Maturity_Sheet
.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Booked_Sheet.Cells(6, 1)
End With
'Closes AC Workbooks and activates the Booked_Sheet
' Error here. It asked the file to be saved. I want to ignore it.
AC_Live_Workbook.Close
AC_Maturity_Workbook.Close
Booked_Sheet.Activate
Application.ScreenUpdating = True
End Sub
The following is to show how you might load the unique column D numbers into a dictionary as its keys and loop that dictionary's keys to add your new sheets. You could do your filter in the same loop, again using the current key of the dictionary for filtering or use it later. This is not intended to be copy-paste-work but to show you the parts you could use.
Option Explicit
Public Sub test()
Dim valuesDict As Object, arr(), i As Long, lastRow As Long
Set valuesDict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'find last row of your numbers
Select Case lastRow
Case Is < 2
Exit Sub
Case 2 '< Load your number into an array
ReDim arr(1, 1)
arr(1, 1) = .Range("D2")
Case Else
arr = .Range("D2:D" & lastRow).Value
End Select
End With
For i = LBound(arr, 1) To UBound(arr, 1) 'Add unique values to the range
valuesDict(arr(i, 1)) = 1
Next
Dim key As Variant
For Each key In valuesDict.keys
If Not Evaluate("ISREF('" & key & "'!A1)") Then 'If sheet doesn't exist add it. Credit to #Rory for this method.
ThisWorkbook.Worksheets.Add
ActiveSheet.NAME = key
End If
Next key
'Other code.......
For Each key In valuesDict.keys
AC_Live_Sheet.Range("$A$1:$DS$" & lastRow_AC_Live).AutoFilter Field:=7, Criteria1:=key
Next key
'Other code
End Sub
I would like to add AutoFilter Criteria to my excel table in separate Subs.
What I have at the moment looks a little something like this
.AutoFilter Field:=deviceTypeColumnId, Criteria1:=[dScenarioIndependent], Operator:=xlOr, _
Criteria2:=[dSmartphoneDeviceType]
What I would like to have is a method to first filter by Criteria1, and then, in another Sub, add Criteria2 to the existing AutoFilter. To my mind, it should look something like this:
Sub firstSub
.AutoFilter Field:=deviceTypeColumnId, Criteria1:=[dScenarioIndependent]
end sub
Sub secondSub
.AutoFilter mode:=xlAddCriteria, Field:=deviceTypeColumnId, Criteria1:=[dSmartphoneDeviceType]
'I know that mode doesn't exist, but is there anything like that?
end sub
Do you know any way to achieve this?
There isn't, that I know of, a way of "adding on" criteria to a filter which has previously been applied.
I have produced a work-around, which would work for what you are attempting to do. You will just have to add on scenarios to the select case statement, going up to the maximum number of filters which you will want to have.
EDIT: what it does; copy the filtered column to a new worksheet, and remove duplicates on that column. You're then left with the values which have been used to filter the column. Assign the values to an array, and then apply the number of elements of the array as a filter on the column, whilst including the new value you wish to filter on.
EDIT 2: added in a function to find the last row for when a table is already filtered (we want the last row, not the last visible row).
Option Explicit
Sub add_filter()
Dim wb As Workbook, ws As Worksheet, new_ws As Worksheet
Dim arrCriteria() As Variant, strCriteria As String
Dim num_elements As Integer
Dim lrow As Long, new_lrow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("data")
Application.ScreenUpdating = False
lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("A1:A" & lrow).Copy 'Copy column which you intend to add a filter to
Sheets.Add().Name = "filter_data"
Set new_ws = wb.Sheets("filter_data")
With new_ws
.Range("A1").PasteSpecial xlPasteValues
.Range("$A$1:$A$" & Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates _
Columns:=1, Header:=xlYes 'Shows what has been added to filter
new_lrow = Cells(Rows.Count, 1).End(xlUp).Row
If new_lrow = 2 Then
strCriteria = .Range("A2").Value 'If only 1 element then assign to string
Else
arrCriteria = .Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'If more than 1 element make array
End If
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
If new_lrow = 2 Then
num_elements = 1
Else
num_elements = UBound(arrCriteria, 1) 'Establish number elements in array
End If
lrow = last_row
Select Case num_elements
Case 1
ws.Range("$A$1:$A$" & lrow).AutoFilter 1, _
Array(strCriteria, "New Filter Value"), Operator:=xlFilterValues
Case 2
ws.Range("$A$1:$A$" & lrow).AutoFilter 1, _
Array(arrCriteria(1, 1), arrCriteria(2, 1), _
"New Filter Value"), Operator:=xlFilterValues
Case 3
ws.Range("$A$1:$A$" & lrow).AutoFilter 1, _
Array(arrCriteria(1, 1), arrCriteria(2, 1), _
arrCriteria(3, 1), "New Filter Value"), Operator:=xlFilterValues
End Select
Application.ScreenUpdating = True
End Sub
Function:
Function last_row() As Long
Dim rCol As Range
Dim lRow As Long
Set rCol = Intersect(ActiveSheet.UsedRange, Columns("A"))
lRow = rCol.Row + rCol.Rows.Count - 1
Do While Len(Range("A" & lRow).Value) = 0
lRow = lRow - 1
Loop
last_row = lRow
End Function
Hope this helps.
To be quite honest I am not entirely sure how to describe what it is I am trying to accomplish? But, here it goes anyway. I have an excel sheet containing one column of IDs and a second column of values that need to be associated to the first column. The problem is that the IDs in column A contain duplicates, which is okay because one ID can qualify for multiple values. What I need is to have a third column pull back the unique id, and a fourth column pull back a semi-colon delimited list of all of the values the id qualifies for. Hopefully the attached image makes sense? For what it's worth I have tried every formula I can think of, and I really know nothing about macros, which is what I am thinking needs to be implemented.
Try below code :
Sub sample()
Dim lastRowA As Long, lastRowC As Long
lastRowA = Range("A" & Rows.Count).End(xlUp).Row
lastRowC = Range("C" & Rows.Count).End(xlUp).Row
Dim rng As Range, cell As Range
Set rng = Range("C2:C" & lastRowC)
Dim rngSearch As Range
Set rngSearch = Range("A1:A" & lastRowA)
Dim rngFind As Range
Dim firstCell As String
For Each cell In rng
Set rngFind = rngSearch.Find(What:=cell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rngFind Is Nothing Then
temp = rngFind.Offset(0, 1)
firstCell = rngFind.Address
Do While Not rngFind Is Nothing
Set rngFind = rngSearch.FindNext(After:=rngFind)
If rngFind.Address <> firstCell Then
temp = temp & ";" & rngFind.Offset(0, 1)
Else
Set rngFind = Nothing
End If
Loop
End If
cell.Offset(0, 1) = temp
Next
End Sub
Here's an alternative approach, that has several advantages
it builkds the list of unique sku's
it clear old data from columns C:D
it will run much faster than looping over a range
Sub Demo()
Dim rngA As Range, rng as Range
Dim datA As Variant
Dim i As Long
Dim sh As Worksheet
Dim dic As Object
Set sh = ActiveSheet ' can change this to your worksheet of choice
Set dic = CreateObject("Scripting.Dictionary")
With sh
' Get data from columns A:B into a variant array
Set rngA = .Range(.Cells(2, 2), .Cells(.Rows.Count, 1).End(xlUp))
datA = rngA
' Create list of unique sku's and built value strings
For i = 1 To UBound(datA)
If dic.Exists(datA(i, 1)) Then
dic(datA(i, 1)) = dic(datA(i, 1)) & ";" & datA(i, 2)
Else
dic.Add datA(i, 1), datA(i, 2)
End If
Next
' Clear exisating data from columns C:D
Set rng = .Range(.Cells(2, 4), .Cells(.Rows.Count, 3).End(xlUp))
If rng.Row > 1 Then
rng.Clear
End If
' Put results into columns C:D
.Range(.Cells(2, 3), .Cells(dic.Count + 1, 3)) = Application.Transpose(dic.Keys)
.Range(.Cells(2, 4), .Cells(dic.Count + 1, 4)) = Application.Transpose(dic.Items)
End With
End Sub
How to add this:
Start the VBS editor (Alt+F11 from excel)
show project explorer, if its not already visible (Ctrl+R)
add a Module (right click on your workbook, Insert, Module)
open the module (dbl click)
Add Option Explicit as the first line, if not already there
copy paste this code into module
How to run it, from Excel
activate the sheet with your data
open macro dialog (Alt+F8)
select Demo from list and run