Доброго времени суток. подскажите макрос для удаления в колонке дубликатов Email адресов. Нужно, чтобы при выделение столбца макрос удалял дубли Email адресов по строчно, оставляя только первый. формат остается такой же без удаления ячеек и смещение строк, удаление только дублей по строчно. скрин и пример приложил.
sotex2 написал: макрос для удаления в колонке дубликатов Email адресов
Скрытый текст
Код
Sub DelDubl()
Dim arr(), iDic As Object, iKey, I&, iTmp
Application.ScreenUpdating = False
With Worksheets("ОКВЕД 17")
arr = .Range("E2:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value
End With
Set iDic = CreateObject("Scripting.Dictionary")
With CreateObject("Scripting.Dictionary")
For I = LBound(arr, 1) To UBound(arr, 1)
For Each iKey In Split(Replace(Trim(arr(I, 1)), ",", ""), " ")
iKey = Trim(iKey)
If Not .Exists(iKey) Then iTmp = iDic.Item(iKey)
iTmp = .Item(iKey)
Next
arr(I, 1) = Join(iDic.Keys, ", ")
iDic.RemoveAll
Next
End With
Worksheets("ОКВЕД 17").Range("F2").Resize(UBound(arr, 1)) = arr
Application.ScreenUpdating = True
End Sub
Sub test()
Dim lrow As Long, arrMail, key, strMail As String, dicTemp As Object
Application.ScreenUpdating = False
lrow = Cells(2, "E").End(xlDown).Row
Set dicTemp = CreateObject("Scripting.Dictionary")
For i = 2 To lrow
arrMail = Split(Trim(Replace(Cells(i, "E"), ", ", " ")), " ")
For j = 0 To UBound(arrMail)
If Not dicTemp.Exists(arrMail(j)) Then
key = dicTemp.Item(arrMail(j))
strMail = strMail & arrMail(j) & ", "
End If
Next j
If Len(strMail) > 0 Then Cells(i, "E") = Left(strMail, Len(strMail) - 2) Else Cells(i, "E") = ""
strMail = ""
Next i
arrMail = Split(Trim(Replace(Cells(2, "E"), ", ", " ")), " ")
Application.ScreenUpdating = True
End Sub
Здравствуйте, спасибо за отклик. в целом макрос работает, но есть небольшой трабл.
1. это когда после выполнения макроса, в конце емайл адреса остается запятая. 2. можно ли сделать выбор по выбору колонки, чтобы каждый раз не лезть в код и постоянно изменять название колонки.
Здравствуйте, спасибо за отклик. в целом макрос работает, но есть небольшой трабл.
1. это когда после выполнения макроса, в конце емайл адреса остается запятая. 2. можно ли сделать выбор по выбору колонки, чтобы каждый раз не лезть в код и постоянно изменять название колонки.
sotex2 написал: 2. можно ли сделать выбор по выбору колонки, чтобы каждый раз не лезть в код и постоянно изменять название колонки.
Скрытый текст
Код
Sub DelDubl()
Dim arr(), iDic As Object, iKey, I&, iTmp
iClmn = InputBox("Введите номер столбца для обработки", "Настройка обработки", "2")
If iClmn = "" Then Exit Sub
On Error Resume Next
If Not IsNumeric(Val(iClmn)) Then
iClmn = Range(iClmn & 1).Column
Else
iClmn = Val(iClmn)
End If
Application.ScreenUpdating = False
With ActiveSheet
arr = .Range(.Cells(2, iClmn), .Cells(.Cells(.Rows.Count, iClmn).End(xlUp).Row, iClmn)).Value
End With
Set iDic = CreateObject("Scripting.Dictionary")
With CreateObject("Scripting.Dictionary")
For I = LBound(arr, 1) To UBound(arr, 1)
iRep = Replace(Replace(Trim(arr(I, 1)), ",", "#"), " ", "#")
For Each iKey In Split(iRep, "#")
iKey = Trim(iKey)
If Not .Exists(iKey) Then iTmp = iDic.Item(iKey)
iTmp = .Item(iKey)
Next
arr(I, 1) = Trim(Join(iDic.Keys, ", "))
iDic.RemoveAll
Next
End With
ActiveSheet.Cells(2, iClmn).Resize(UBound(arr, 1)) = arr
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
написал: Удалите или закомментируйте строку КодOn Error resume next и напишите на какой строке кода возникает ошибка
После выбора колонки и запуска, никакая ошибка не появляется, остается все по прежнему без удаления дублей. если удалить - "On Error resume next", то после запуска макроса выводится ошибка, смотрите скрин 1.
Проблема, возможно, такая-же, как в этой теме? Код ниже работает с ВЫДЕЛЕННЫМ столбцом (или ячейкой в нужном столбце). Выделить весь столбец (или встать на любую ячейку в нужном столбце) и запустить макрос. Запятые тоже удаляет
Скрытый текст
Код
Sub DelDubl()
Dim arr(), iDic As Object, iKey, I&, iRep, iClmn, iTmp
On Error Resume Next
iClmn = Selection.Column
Application.ScreenUpdating = False
With ActiveSheet
arr = .Range(.Cells(2, iClmn), .Cells(.Cells(.Rows.Count, iClmn).End(xlUp).Row, iClmn)).Value
End With
Set iDic = CreateObject("Scripting.Dictionary")
With CreateObject("Scripting.Dictionary")
For I = LBound(arr, 1) To UBound(arr, 1)
iRep = Replace(Replace(Trim(arr(I, 1)), ",", "#"), " ", "#")
For Each iKey In Split(iRep, "#")
iKey = Trim(iKey)
If Not .Exists(iKey) Then iTmp = iDic.Item(iKey)
iTmp = .Item(iKey)
Next
arr(I, 1) = Trim(Join(iDic.Keys, ", "))
If Right(arr(I, 1), 1) = "," Then arr(I, 1) = Left(arr(I, 1), Len(arr(I, 1)) - 1)
iDic.RemoveAll
Next
End With
ActiveSheet.Cells(2, iClmn).Resize(UBound(arr, 1)) = arr
Application.ScreenUpdating = True
End Sub