Erase duplicated value within row of uncertain size - excel

I want to write a code that will erase the duplicated value within a row of uncertain size, i.e. I don't know where the duplicated value will apear.
I thought that I may be able to use RemoveDuplicates property within a range but it only works for duplicates within column. That's why I am stacked.
This is the case before running the code:
And this is my desired outcome:
I really wish to have a code that will use resizable range with rows.count as I said, I don't know where the duplicate can appear and the row can be very long (up to 500 records).
This is what tried but obviously, I cannot use as there is no Remove duplicate property within row:
Sub RemoveDuplicates()
Dim ws1 As Worksheet
Set ws1 = Sheets("Sheet1")
Dim rng As Range
Dim LastCol As Integer
With ws1
LastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(2, 1), .Cells(2, LastCol))
rng.RemoveDuplicates ????
End With
I would appreciate any help.

You could do it like that
Sub RemoveDuplicates()
Dim ws1 As Worksheet
Set ws1 = Sheets("Sheet1")
Dim rng As Range
Dim LastCol As Integer
With ws1
LastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(2, 1), .Cells(2, LastCol))
'rng.RemoveDuplicates ????
End With
Dim v As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
v = rng
Dim i As Long
For i = LBound(v, 2) To UBound(v, 2)
If dict.Exists(v(1, i)) Then
v(1, i) = vbNullString
Else
dict.Add v(1, i), v(1, i)
End If
Next i
rng = v
End Sub

A SET data structure is more appropriate for this kind of operation, but Excel provides Dictionary, and as Shai Radio mentioned in the comments, it could be used here. Refer this to reference dictionary in your project
Does VBA have Dictionary Structure?
Your code can then be modified to the following:
Sub RemoveDuplicates()
Dim ws1 As Worksheet
Set ws1 = Sheets("Sheet1")
Dim rng As Range
Dim dict As New Scripting.Dictionary
Dim LastCol As Integer
With ws1
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To LastCol
If Not dict.Exists(.Cells(1, i).Value) Then
dict.Add .Cells(1, i).Value, 1
Else
.Cells(1, i).ClearContents
End If
Next i
End With
End Sub

if you want to use RemoveDuplicates() feature in a row-like range, you can use a "helper" column-like range to put your data into, RemoveDuplicates and paste the result back to your original range
Sub RemoveDuplicates()
Dim ws1 As Worksheet
Set ws1 = Sheets("Sheet1")
Dim dataRng As Range, helpRng As Range
With ws1
Set dataRng = .Range("A2", .Cells(2, Columns.Count).End(xlToLeft)) ' this is your original data range
With .UsedRange
Set helpRng = .Cells(1, .Columns.Count + 1).Resize(dataRng.Columns.Count) ' ' this is "out of town" helper range, with as many rows as your data range columns
End With
With helpRng
.Value = Application.Transpose(dataRng.Value)
.RemoveDuplicates Columns:=Array(1), Header:=xlNo
dataRng.Value = Application.Transpose(.Value)
.Clear
End With
End With
End Sub

Related

Remove duplicate rows based on all columns via VBA

I found a great solution from this post: Removing duplicate rows after checking all columns
Sub Remove_DuplicateRows()
Dim intArray As Variant, i As Integer
Dim rng As Range
Dim ws As Worksheet
Call Open_Workbook
Set ws = Workbooks("Sales2021.xlsm").Sheets("Reporting Template")
ws.Activate
Set rng = ws.UsedRange.Rows
With rng
ReDim intArray(0 To .Columns.Count - 1)
For i = 0 To UBound(intArray)
intArray(i) = i + 1
Next i
.RemoveDuplicates Columns:=(intArray), Header:=xlYes
End With
End Sub
I tried the script, and wanted to adjust to my case: I want to delete all duplicated rows based on all columns except the first column (i.e., columns B to U). Should I use ws.Range("B2:U3000") instead of UsedRange?
You can either use ws.Range("B2:U3000") or below code
Set rng = ws.UsedRange.Offset(0, 1).Resize(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count - 1)
The final code should look like this.
Sub Remove_DuplicateRows()
Dim intArray As Variant, i As Integer
Dim rng As Range
Dim ws As Worksheet
Call Open_Workbook
Set ws = Workbooks("Sales2021.xlsm").Sheets("Reporting Template")
ws.Activate
Set rng = ws.UsedRange.Offset(0, 1).Resize(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count - 1)
With rng
ReDim intArray(0 To .Columns.Count - 1)
For i = 0 To UBound(intArray)
intArray(i) = i + 1
Next i
.RemoveDuplicates Columns:=(intArray), Header:=xlYes
End With
End Sub

Populate a column with input based on partial match from another column

I have a sheet 1 where the column contains a list of domains e.g. www.nonsence.bg/sport, www.example.cn/streets, www.news.gr/sports
I would like to populate the Country input in column A based on the "KEY" table that is stored within the sheet 4 where column A = the domain (e.g. ".gr/", ".bg/", ".cn/") and column B = country (Greece, China, Bulgaria).
I use the following code for find/replace, but with the partial match it seems to be a bit more complex:
Sub substitute()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim FndList, x&
Set Sh1 = Sheets(1)
Set Sh2 = Sheets(3)
FndList = Sh2.Cells(1, 1).CurrentRegion
For x = 1 To UBound(FndList)
Sh1.Cells.Replace What:=FndList(x, 1), replacement:=FndList(x, 2), LookAt:=xlPart
Next
End Sub
Especially since your entries in KEY table are of the form xx/, it's pretty easy to do this with a formula:
I made the key table into a "real" table and am using structured references, but you can change that to normal references if you prefer
B2: =INDEX(tblKEY[Country], MATCH(TRUE,ISNUMBER(MATCH("*" & tblKEY[Domain]&"*",A2,0)),0))
KEY table
(named tblKEY)
Results
You can do the same thing with VBA and the Range.Find method, if you must use VBA for some other reason:
Option Explicit
Sub Country()
Dim wsSrc As Worksheet, LO As ListObject
Dim rSrc As Range, C As Range, CC As Range
'Change these to represent your actual locations
Set wsSrc = ThisWorkbook.Worksheets("sheet5")
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion.Offset(rowoffset:=1)
Set LO = wsSrc.ListObjects("tblKEY")
Application.ScreenUpdating = False
rSrc.Columns(2).ClearContents
For Each CC In LO.DataBodyRange.Columns(1).Cells
With rSrc.Columns(1)
Set C = .Find(what:=CC.Value, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
If Not C Is Nothing Then
C.Offset(0, 1) = CC.Offset(0, 1)
End If
End With
Next CC
End Sub
If I understood what you want correctly, this should work
Sub UpdateCountries()
Dim vCountriesList As Variant
Dim i As Long
Dim j As Long
Dim lLastRow As Long
With ThisWorkbook.Sheets("Sheet4")
vCountriesList = .Range(.Cells(2, "A"), .Cells(Rows.count, "B").End(xlUp)).Value
End With
With ThisWorkbook.Sheets("Sheet1")
lLastRow = .Cells(Rows.count, "H").End(xlUp).Row
For i = 2 To lLastRow
For j = 1 To UBound(vCountriesList, 1)
If InStr(1, .Cells(i, "H"), vCountriesList(j, 1), vbTextCompare) > 0 Then
If .Cells(i, "A").Value <> vCountriesList(j, 2) Then
.Cells(i, "A").Value = vCountriesList(j, 2)
End If
Exit For
End If
Next j
Next i
End With
End Sub

Covert a range to string values using array

I want to convert a range of cells from integer to String. However, since I have so much data, I can't use a standard loop for ranges as it takes too long.
Instead I thought to use the array and convert the desired range(array) into string values.
This is what I tried to do by modifying my standardcode that converts range into string just instead range I would use in the below the array:
Sub CovertToString()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim sArray As Variant
Dim LastRow As Integer
Dim cell As Variant
With ws
LastRow = .Cells(.rows.Count, 1).End(xlUp).row
sArray = .Range(.Cells(1, 8), .Cells(LastRow, 8))
For Each cell In sArray
cell = "'" & cell.Value
Next
End With
End Sub
Unfortunately, It does not work which I understand as I am not sure how to correct it.
This way will convert the cell formats to Text:
Sub ConvertToString()
Dim ws As Worksheet
Dim LastCell As Range
Dim rCell As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
Set LastCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(, 7)
'Convert format to 'Text'
.Range(.Cells(1, 8), LastCell).NumberFormat = "#"
End With
End Sub
This way will copy the range to an array and add a ' to each value before posting back to the sheet:
Sub ConvertToString()
Dim ws As Worksheet
Dim LastCell As Range
Dim vValues() As Variant
Dim R As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
'Your code is looking for last cell in column A, so offset to column H once found.
'This is a reference to the last cell, not the row number so can be used in the range.
Set LastCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(, 7)
vValues = .Range(.Cells(1, 8), LastCell).Value
'Add a ' to each value.
For R = 1 To UBound(vValues, 1)
vValues(R, 1) = "'" & vValues(R, 1)
Next R
'Paste back to sheet.
.Range(.Cells(1, 8), LastCell) = vValues
End With
End Sub
Further reading on arrays & worksheets

VBA - Compare Sheet1 values to Sheet2, copy/paste the result to Sheet3

I'm trying to compare sheet1 "A" column values to sheet2 "E:E" column values and copy/paste the whole line of every match to sheet3. Please help me to complete this task. I'm very new to VBA.
Thank you very much in advance!
Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("Sheet2").Range("E:E" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 1 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet1").Cells(iCtr, 1).EntireRow.Copy
Sheets("Sheet3").Select.Paste
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Sub DelDupsTwoLists()
Dim lastRowWs1 As Long, lastRowWs2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)
lastRowWs1 = LastRow(ws1.Name, 1)
lastRowWs2 = LastRow(ws2.Name, 5) 'E = 5
Dim myCell1 As Range, myCell2 As Range
Dim ws1Range As Range, ws2Range As Range
Set ws1Range = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(lastRowWs1, 1))
Set ws2Range = ws2.Range(ws2.Cells(1, "E"), ws2.Cells(lastRowWs2, 1))
Dim rangeToDelete As Range
For Each myCell1 In ws1Range
For Each myCell2 In ws2Range
If myCell1.Value = myCell2.Value Then
Dim lastRowWs3: lastRowWs3 = LastRow(ws3.Name, 1) + 1
myCell2.EntireRow.Copy Destination:=ws3.Cells(lastRowWs3, 1)
If Not rangeToDelete Is Nothing Then
Set rangeToDelete = Union(rangeToDelete, myCell2.EntireRow)
Else
Set rangeToDelete = myCell2.EntireRow
End If
End If
Next
Next
If Not rangeToDelete Is Nothing Then
Debug.Print "Deleting rangeToDelete - "; rangeToDelete.Address
rangeToDelete.Delete
End If
Debug.Print "Done!"
End Sub
Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
Pretty much I rewrote the whole code from scratch. It pretty much uses the initial n2 complexity, but is rather faster than that, because the deletion of the rows in WorkSheet(2) is done in a single last step rangeToDelete.Delete, which saves a lot of time.
Pretty much, the code defines 2 ranges with which is works - ws1Range and ws2Range, using the LastRow function. Once it defines them, it starts looping through them and comparing them. Hence the n2 complexity. In case of equal values, the row is copied and the cell is added to the rangeToDelete.
Note - it will probably not work as "out of the box solution", but try to debug further with F8 and see what happens.
Additionally:
Using Integer is not a great idea in VBA.
"_" in the Sub name is used for Events in VBA, thus it is not a great idea to use it. (although it works)
How to avoid using Select in Excel VBA
Give this a try (see comments in code for more details):
Sub DelDups_TwoLists()
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
With ActiveWorkbook
Dim wsSrc As Worksheet: Set wsSrc = .Sheets("Sheet1") 'declare and set the source worksheet
Dim wsDst As Worksheet: Set wsDst = .Sheets("Sheet3") 'declare and set the destination worksheet
Dim R1 As Long, R2 As Long, C As Long, lRow As Long, lCol As Long 'declare variables to use
With wsSrc
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 'get the last column value in the source sheet, at row 1, will reuse this laster
Dim arrData_1 As Variant: arrData_1 = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1)) 'declare and allocate the source data to an array
End With
With .Sheets("Sheet2")
Dim arrData_2 As Variant: arrData_2 = .Range("E1:E" & .Cells(Rows.Count, 1).End(xlUp).Row) 'declare and allocate the compare data to an array
End With
End With
With wsDst
For R1 = LBound(arrData_1) To UBound(arrData_1) 'for each row in the source data
For R2 = LBound(arrData_2) To UBound(arrData_2) 'for each row in the compare data
If arrData_1(R1, 2) = arrData_2(R2, 1) Then 'if there is a match
lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'get the last row in the destination sheet
.Range(.Cells(lRow, 1), .Cells(lRow, lCol)).Value = _
wsSrc.Range(wsSrc.Cells(R1, 1), wsSrc.Cells(R1, lCol)).Value 'allocate the matching values
Exit For 'exit early here if there is a match, go to next row to check
End If
Next R2
Next R1
End With
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

How to save data with formats and values in excel using VBA?

I am trying to save data from sheet("Billing") to another sheets("Bill_Register") with formats and values not formulas. Pasteformats and pastevalues are working separately not together. Please suggest me a better VBA. Thanks in advance.
Sub Save_invoice()
Dim i As Integer
Dim last As Long
Dim rng As Range, rng2 As Range
last = Sheets("Bill_Register").Range("A100000").End(xlUp).Row
Set rng = Sheets("Billing").Range("A1:J42")
Set rng2 = Sheets("Bill_Register").Range("A" & last + 2)
rng.Copy
rng2.PasteSpecial Paste:=xlPasteFormats
rng.Copy
rng2.PasteSpecial Paste:=xlPasteValues
End Sub
If you have merged cells and use xlPasteValues then an error will occur.
use variant array.
Sub Save_invoice()
Dim i As Integer
Dim last As Long
Dim rng As Range, rng2 As Range
Dim vDB
last = Sheets("Bill_Register").Range("A100000").End(xlUp).Row
Set rng = Sheets("Billing").Range("A1:J42")
vDB = rng '<~~ set array
Set rng2 = Sheets("Bill_Register").Range("A" & last + 2)
rng.Copy
rng2.PasteSpecial Paste:=xlPasteFormats
rng2.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB '<~~ get value
End Sub
If rng and rng2 have the exactly same size (rows and columns) then you can use this to get the values:
rng2.Cells.Value = rng.Cells.Value
Some MCVE:
Public Sub TestMe()
Dim rng As Range
Dim rng2 As Range
Set rng = Range("A1:B2")
Set rng2 = Range("D2:E3")
rng2.Cells.Value = rng.Cells.Value
End Sub
If you are interested in the number formatting etc. but not necessarily the fill colour etc. then you could use:
Rng.Copy
rng2.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
There is no reason to copy twice, once it is in the clipboard it is there till replaced.
Paste the values first then the format:
Sub Save_invoice()
Dim i As Integer
Dim last As Long
Dim rng As Range, rng2 As Range
last = Sheets("Bill_Register").Range("A100000").End(xlUp).Row
Set rng = Sheets("Billing").Range("A1:J42")
Set rng2 = Sheets("Bill_Register").Range("A" & last + 2)
rng.Copy
rng2.PasteSpecial Paste:=xlPasteValues
rng2.PasteSpecial Paste:=xlPasteFormats
End Sub

Resources