Assume I have data in column (A) like the following:
Names
Yasser
Hany
Ahmed
Reda
Ahmed
Yasser
Reda
Yasser
Duplicates can be detected using such a code
Sub Find_Duplicates()
Dim e, x(), dic As Object, cel As Range, lr As Long, i As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each cel In Range("A1:A" & lr)
If Not .Exists(cel.Value) Then
.Item(cel.Value) = cel.Value & "^" & cel.Address(0, 0)
Else
.Item(cel.Value) = Split(.Item(cel.Value), "^")(0) & " | " & cel.Value & "^" & Split(.Item(cel.Value), "^")(1) & " | " & cel.Address(0, 0)
End If
Next cel
If .Count Then
ReDim x(1 To .Count, 1 To 2)
For Each e In .Keys
If InStr(.Item(e), "|") > 0 Then
i = i + 1
x(i, 1) = Split(.Item(e), "^")(0)
x(i, 2) = Split(.Item(e), "^")(1)
End If
Next e
End If
Columns("F:G").ClearContents
Range("F1:G1").Value = Array("Duplicate Entries", "Address")
If i > 0 Then Range("F2").Resize(i, 2).Value = x
End With
Application.ScreenUpdating = True
End Sub
The output would be in columns F & G like that
What I am trying to get is like that (in Column B)
If you decide on formulas instead, then you could use:
Formula in B2:
=IF(COUNTIF(A$2:A$9,A2)>1,"Duplicate"&MATCH(A2,UNIQUE(FILTER(A$2:A$9,COUNTIF(A$2:A$9,A$2:A$9)>1)),0),"")
Non-ExcelO365 users could use:
=IF(COUNTIF(A$2:A$9,A2)>1,IF(MATCH(A2,A$1:A$9,0)=ROW(),"Duplicate"&MAX(IFERROR(--MID(B$1:B1,10,99),0))+1,INDEX(B$1:B1,MATCH(A2,A$1:A$9,0))),"")
Be sure to accept the formula through CtrlShiftEnter
You could modify your subroutine like this:
Sub Find_Duplicates()
Dim e, x(), dic As Object, cel As Range, lr As Long, i As Long, j As Long, arr() As String
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each cel In Range("A1:A" & lr)
If Not .Exists(cel.Value) Then
.Item(cel.Value) = cel.Value & "^" & cel.Address(0, 0)
Else
.Item(cel.Value) = Split(.Item(cel.Value), "^")(0) & " | " & cel.Value & "^" & Split(.Item(cel.Value), "^")(1) & " | " & cel.Address(0, 0)
End If
Next cel
If .Count Then
ReDim x(1 To .Count, 1 To 2)
For Each e In .Keys
If InStr(.Item(e), "|") > 0 Then
i = i + 1
arr = Split(Split(.Item(e), "^")(1), "|")
For j = LBound(arr) To UBound(arr)
Set cel = Range(Trim(arr(j)))
Cells(cel.Row, cel.Column + 1).Value = "Duplicate" & CStr(i)
Next j
End If
Next e
End If
End With
Application.ScreenUpdating = True
End Sub
Here, the cell addresses are split from each item and into an array of strings. Each cell address is used to move one cell to the right and then write the duplicate number there.
Related
I looking for a way to speed up my vba code using Index, Match function
My code use about 20 seconds to run.
Looking for a solution here, it looks as if Ubound can be faster
Thanks for helping !
Sub feuille_distinct()
Dim k As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
timer0 = Timer()
With Sheets("DEDOUBL")
ThisWorkbook.Sheets("DEDOUBL").Activate
col_sinistres = "A"
Derlig = .Range(col_sinistres & .Rows.Count).End(xlUp).Row
For k = 2 To Derlig
Cells(k, 2).Value = WorksheetFunction.Index(Range("ALLSIN_courrier"),
WorksheetFunction.Match(Cells(k, 1).Value, Range("ALLSIN_claimnumber"), 0))
Cells(k, 3).Value = WorksheetFunction.Index(Range("ALLSIN_act"),
WorksheetFunction.Match(Cells(k, 1).Value, Range("ALLSIN_claimnumber"), 0))
Next k
End With
Debug.Print Timer - timer0
ThisWorkbook.Sheets("SIMULATEUR").Activate
Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Please, try the next code:
Sub feuille_distinct()
Dim k As Long, timer0 As Double, sh As Worksheet, col_sinistres As String, Derlig As Long, arrA, arr
Set sh = ThisWorkbook.Sheets("DEDOUBL")
timer0 = Timer()
col_sinistres = "A"
Derlig = sh.Range(col_sinistres & sh.rows.count).End(xlUp).row
arrA = sh.Range("A2:A" & Derlig).value 'put the range in an array
arr = sh.Range("B2:C" & Derlig).value 'put the range in an array
For k = 1 To UBound(arr) 'iterate between the array elements which is much faster than iterating a range
arr(k, 1) = WorksheetFunction.Index(Range("ALLSIN_courrier"), WorksheetFunction.match(arrA(k, 1), Range("ALLSIN_claimnumber"), 0))
arr(k, 2) = WorksheetFunction.Index(Range("ALLSIN_act"), WorksheetFunction.match(arrA(k, 1), Range("ALLSIN_claimnumber"), 0))
Next k
sh.Range("B2").Resize(UBound(arr), UBound(arr, 2)).value = arr 'drop the processed array result at once
Debug.Print Timer - timer0
ThisWorkbook.Sheets("SIMULATEUR").Activate: Range("A1").Select
End Sub
Using a dictionary object with claim number as the key, index as the value.
Sub feuille_distinct()
Const col_sinistres = "A"
Dim t0 As Single, Derlig As Long, k As Long, i As Long
Dim dict, key As String, ar, arCour, arAct, arOut
t0 = Timer()
ar = Range("ALLSIN_claimnumber")
arCour = Range("ALLSIN_courrier")
arAct = Range("ALLSIN_act")
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(ar)
key = Trim(ar(i, 1))
dict(key) = i
Next
With ThisWorkbook.Sheets("DEDOUBL")
' copy from sheet
Derlig = .Range(col_sinistres & .Rows.Count).End(xlUp).Row
arOut = .Range("A2:C" & Derlig).Value2
' update
For k = 1 To Derlig - 1
key = Trim(arOut(k, 1))
If dict.exists(key) Then
i = dict(key)
arOut(k, 2) = arCour(i, 1)
arOut(k, 3) = arAct(i, 1)
Else
MsgBox key & " does not exist", vbExclamation
End If
Next k
' copy to sheet
.Range("A2:C" & Derlig).Value2 = arOut
End With
MsgBox "Finished in " & Format(Timer - t0, "0.00") & " secs", vbInformation
ThisWorkbook.Sheets("SIMULATEUR").Activate
End Sub
Using a dictionary with no hard coded ranges in main sub.
'In sheet Phones lookup col F at LogFileSh sheet col CE,CF and return
'the results in col D sheet Phones. Row of F+D is 2 and row CE+CF is 2.
Sub RunDictionaryVLookup()
Call GeneralDictionaryVLookup(Phones, LogFileSh, "F", "CE", "CF", "D", 2, 2)
End Sub
Sub GeneralDictionaryVLookup(ByVal shtResault As Worksheet, ByVal shtsource As Worksheet, _
ByVal colLOOKUP As String, ByVal colDicLookup As String, ByVal colDicResault As String, ByVal colRESULT As String, _
ByVal rowSource As Long, ByVal rowResult As Long)
Dim x As Variant, x2 As Variant, y As Variant, y2() As Variant
Dim i As Long
Dim dict As Object
Dim LastRow As Long
Set dict = CreateObject("Scripting.Dictionary")
With shtsource
LastRow = .Range(colDicLookup & Rows.Count).End(xlUp).row
x = .Range(colDicLookup & rowSource & ":" & colDicLookup & LastRow).Value
x2 = .Range(colDicResault & rowSource & ":" & colDicResault & LastRow).Value
For i = 1 To UBound(x, 1)
dict.item(x(i, 1)) = x2(i, 1)
Debug.Print dict.item(x(i, 1))
Next i
End With
'map the values
With shtResault
LastRow = .Range(colLOOKUP & Rows.Count).End(xlUp).row
y = .Range(colLOOKUP & rowResult & ":" & colLOOKUP & LastRow).Value 'looks up to this range
ReDim y2(1 To UBound(y, 1), 1 To 1) '<< size the output array
For i = 1 To UBound(y, 1)
If dict.Exists(y(i, 1)) Then
y2(i, 1) = dict(y(i, 1))
Else
y2(i, 1) = "NA"
End If
Next i
.Range(colRESULT & rowResult & ":" & colRESULT & LastRow).Value = y2 '<< place the output on the sheet
End With
End Sub
I am trying to eliminate line items that cancel each other out.
For example, below the two rows that add to zero would be deleted (i.e., 87.1 and -87.1).
-87.1
890
87.1
898989
The code that I am using mostly works but in cases where there are numerous lines with the same values it is deleting all of them instead of just one matching value per observation. For example, below, I would want it to cancel out two of the -87.1s and two of the 87.1s but one would be leftover because there is no number directly offsetting it.
-87.1
890
87.1
898989
87.1
-87.1
-87.1
Sub x()
Dim n As Long, rData As Range
Application.ScreenUpdating = False
n = Range("C" & Rows.Count).End(xlUp).Row
Range("AV2:AV" & n).Formula = "=IF(I2=0,0,COUNTIFS($C$2:$C$" & n & ",C2,$I$2:$I$" & n & ",-I2))"
With ActiveSheet
.AutoFilterMode = False
.Rows(1).AutoFilter field:=48, Criteria1:=">0"
With .AutoFilter.Range
On Error Resume Next
Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rData Is Nothing Then
rData.EntireRow.Delete shift:=xlUp
End If
End With
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
I think you need something like this:
Sub DeleteOppositeNumbers()
Dim Fnd As Range, r As Long
'By: Abdallah Ali El-Yaddak
Application.ScreenUpdating = False
'Loop through the column bottom to top.
For r = Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
If Cells(r, 3).Value > 0 Then 'If the value is positive
'Sreach for it's opposite
Set Fnd = Columns(3).Find(-Cells(r, 3).Value, LookAt:=xlWhole)
'If found, delete both.
If Not Fnd Is Nothing Then Rows(r).Delete: Fnd.EntireRow.Delete
End If
Next
'Just to restore normal behaviour of sreach
Set Fnd = Columns(3).Find(Cells(3, 2).Value, LookAt:=xlPart)
Application.ScreenUpdating = True
End Sub
Perhaps Something Simpler:
Sub x()
Dim ar() As Variant
Dim i As Integer
Dim j As Integer
Dim n As Integer
n = Range("C" & Rows.Count).End(xlUp).Row
Range("AV2:AV" & n).Formula = "=IF(I2=0,0,COUNTIFS($C$2:$C$" & n & ",C2,$I$2:$I$" & n & ",-I2))"
ar = ActiveSheet.Range("AV2:AV" & last).Value
For i = LBound(ar) To UBound(ar)
For j = LBound(ar) To UBound(ar)
If i <> j Then
If ar(i, 1) = ar(j, 1) Then
ar(i, 1) = ""
ar(j, 1) = ""
End If
End If
Next
Next
For i = LBound(ar) To UBound(ar)
ActiveSheet.Range("AV" & i + 1).Value = ar(i, 1)
Next
ActiveSheet.Range("AV2:AV" & last).SpecialCells(xlCellTypeBlanks).Delete xlUp
End Sub
I have tried and tested this one.
You could try:
Option Explicit
Sub test()
Dim arr As Variant
Dim LastRow As Long, i As Long, j As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = Range("A1:A" & LastRow)
For i = UBound(arr) To LBound(arr) Step -1
For j = UBound(arr) - 1 To LBound(arr) Step -1
If arr(i, 1) + arr(j, 1) = 0 Then
.Rows(i).EntireRow.Delete
.Rows(j).EntireRow.Delete
Exit For
End If
Next j
Next i
End With
End Sub
I am building on some code, partly cut and paste from other posts. I need to concatenate with a VBA code keeping the format and running through rows to output in last cell in each row. (Can't paste image) so hope description is clear:
In A1:D1 values are RED,BLUE,GREEN
In A2:D2 Values are YELLOW,PURPLE,ORANGE
OUTPUT IN E1 should concatenate these values, keeping font colour. Each value should have "ALT ENTR" to give line break.
Next row should be displayed in E2, and so on
'************************************************************************************
Sub test()
Dim rng As Range: Set rng = Application.Range("a1:c1") 'Not yet looping
Dim row As Range
For Each row In rng.Rows
'Debug.Print col.Column
Call concatenate_cells_formats(Cells(1, 4), rng) 'Not yet looping
Next row
End Sub
Sub concatenate_cells_formats(cell As Range, source As Range)
'Anon
Dim c As Range
Dim i As Integer
i = 1
With cell
.Value = vbNullString
.ClearFormats
For Each c In source
.Value = .Value & " " & Trim(c)
Next c
.Value = Trim(.Value)
For Each c In source
With .Characters(Start:=i, Length:=Len(Trim(c))).Font
.Name = c.Font.Name
.FontStyle = c.Font.FontStyle
.Size = c.Font.Size
.Strikethrough = c.Font.Strikethrough
.Superscript = c.Font.Superscript
.Subscript = c.Font.Subscript
.OutlineFont = c.Font.OutlineFont
.Shadow = c.Font.Shadow
.Underline = c.Font.Underline
.ColorIndex = c.Font.ColorIndex
End With
.Characters(Start:=i + Len(c), Length:=1).Font.Size = 1
i = i + Len(Trim(c)) + 1
Next c
End With
End Sub
'*****************************************************************************
Option Explicit
Sub concColour()
Dim i As Long, j As Long, s As Long, l As Long, clr As Long, vals As Variant
With Worksheets("sheet4")
For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
vals = Application.Transpose(Application.Transpose(Intersect(.Range("A:D"), .Rows(i)).Value2))
.Cells(i, "E") = Join(vals, vbLf)
s = 1
For j = LBound(vals) To UBound(vals)
l = Len(vals(j))
clr = .Cells(i, "A").Offset(0, j - 1).Font.Color
With .Cells(i, "E").Characters(Start:=s, Length:=l).Font
.Color = clr
End With
s = s + l + 1
Next j
.Cells(i, "E").Font.Size = 4
Next i
End With
End Sub
enter image description here
I think you require something like this. Change source font and formats as per your requirement.
Sub Adding_T()
Dim lena As Integer
Dim lenc As Integer
Dim lend As Integer
Dim lene As Integer
Dim LastRow As Long
Dim nrow As Long
With Worksheets("Sheet2") 'Change sheet as per your requirement
LastRow = .Cells(.Rows.Count, "A").End(xlUp).row
For nrow = 1 To LastRow
.Range("E" & nrow) = .Range("A" & nrow).Value2 & Chr(13) & Chr(10) & .Range("B" & nrow).Value2 & _
Chr(13) & Chr(10) & .Range("C" & nrow).Value2 & Chr(13) & Chr(10) & .Range("D" & nrow).Value2
lena = Len(.Range("A" & nrow).Value2)
lenc = lena + 2 + Len(.Range("B" & nrow).Value2)
lend = lenc + 2 + Len(.Range("C" & nrow).Value2)
lene = lend + 2 + Len(.Range("D" & nrow).Value2)
For i = 1 To lena
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("A" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lena + 2 To lenc
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("B" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lenc + 2 To lend
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("C" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
For i = lend + 2 To lene
.Range("E" & nrow).Characters(Start:=i, Length:=1).Font.Color = _
.Range("D" & nrow).Characters(Start:=i, Length:=1).Font.Color
Next i
Next
End With
End Sub
Snapshot of trial:
EDIT: OP Preferred code does not permit looping through the Range. Amended his Sub Test() to allow looping through the range.
Sub Test2()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = ThisWorkbook.ActiveSheet
Dim rng As Range
Dim row As Range
Dim rw As Long
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).row
rw = 1
For rw = 1 To LastRow
Set rng = ws.Range("A" & rw & ":C" & rw)
Call concatenate_cells_formats(Cells(rw, 4), rng)
Next
End Sub
Results are as per snapshot appended here.
I have a small issue with my code. The code is below.
Private Sub CommandButton1_Click()
Dim Rng As Range, Dn As Range, n As Long
Dim pType As String
Dim oMax As Long
Set Rng = Range(Range("E1"), Range("E" & Rows.Count).End(xlUp))
Const StartNum = 1
pType = Me.TextBox1.Value
if pType = vbNullString Then MsgBox "Please Select Option from Combo Box": Exit Sub
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Left(Dn.Value, 1) = pType Then
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Mid(Dn, 2)
oMax = Application.Max(.Item(Dn.Value), Mid(Dn, 2))
Else
MsgBox "Number Exists:-" & Dn.Value
End If
End If
Next
If .Count = 0 Then
Range("E" & Rng.Count + 1) = pType & StartNum
Else
Range("E" & Rng.Count + 1) = pType & oMax + 1
End If
End With
End Sub
This code starts generating number from the 2nd row while i want the starting row should be 5. i tried to change the range value from E1 to E5 but it didn't work.
Kindly review and suggest the modification.
Thanks.
You just have to change the below line
Range("E" & Rng.Count + 1) = pType & StartNum
to
Range("E" & Rng.Count + 4) = pType & StartNum
In the list bellow it's an Excel Range, I need to choose two numbers equals to 100 so in return I want to get (30 & 70) or (60 & 40). Can I do that dynamically
I use Excel but if you have any suggestion of other programs it would be fine.
A
30
60
70
40
here the code without verification of duplicated pairs
Sub test()
Dim x&, lastR&, oCell1 As Range, oCell2 As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
x = 1
lastR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For Each oCell1 In ActiveSheet.Range("A1:A" & lastR)
For Each oCell2 In ActiveSheet.Range("A1:A" & lastR)
If oCell1.Value + oCell2.Value = 100 Then
Dic.Add x, "(" & oCell1.Value & " & " & oCell2.Value & ")"
x = x + 1
End If
Next
Next
For Each Key In Dic
Debug.Print Key, Dic(Key) 'output in immediate window all possible
Next
MsgBox Dic(WorksheetFunction.RandBetween(1, Dic.Count))
End Sub
here the result
here the code with verification of duplicated pairs
Sub test()
Dim x&, S$, S2$, check%, lastR&, oCell1 As Range, oCell2 As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
x = 1
lastR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For Each oCell1 In ActiveSheet.Range("A1:A" & lastR)
For Each oCell2 In ActiveSheet.Range("A1:A" & lastR)
check = 0
If oCell1.Value + oCell2.Value = 100 Then
S = "(" & oCell1.Value & " & " & oCell2.Value & ")"
S2 = "(" & oCell2.Value & " & " & oCell1.Value & ")"
For Each Key In Dic
If Dic(Key) = S Or Dic(Key) = S2 Then
check = 1: Exit For
End If
Next
If check = 0 Then
Dic.Add x, S
Debug.Print x, Dic(x)
x = x + 1
End If
End If
Next
Next
MsgBox Dic(WorksheetFunction.RandBetween(1, Dic.Count))
End Sub
here the result
With your data in A1 thru A4, try this macro:
Sub JustKeepTrying()
Dim N As Long, M As Long, wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Do
N = wf.RandBetween(1, 4)
M = wf.RandBetween(1, 4)
If N <> M Then
If Cells(M, 1) + Cells(N, 1) = 100 Then
MsgBox Cells(M, 1).Address & vbTab & Cells(M, 1).Value & vbCrLf _
& Cells(N, 1).Address & vbTab & Cells(N, 1).Value
Exit Sub
End If
End If
Loop
End Sub
Assuming you have in range A1:a11 numbers from 0 to 100 step by 10 [0,10,20,...,90,100] you could use this logic (here, result is highlighted with blue color)
Set BaseRange = Range("A1:a11")
BaseRange.ClearFormats
'first number- rundomly find
With BaseRange.Cells(Int(Rnd() * BaseRange.Cells.Count) + 1)
.Interior.Color = vbBlue
FirstNo = .Value
End With
'second number find by difference- error handling required if there is no matching value for each number
BaseRange.Find(100 - FirstNo).Interior.Color = vbBlue