Добрый день уважаемые форумчанье! файл в приложении, по нему нужна следующая помощь: 1. исключить из списка повторяющееся адресса; 2. убрать ссылки на все адресса (выделены синим); 3.ко всем адрессам в списке добавить в конце знак ";"
заранее спасибо за любую помощь
Добрый день уважаемые форумчанье! файл в приложении, по нему нужна следующая помощь: 1. исключить из списка повторяющееся адресса; 2. убрать ссылки на все адресса (выделены синим); 3.ко всем адрессам в списке добавить в конце знак ";"
Sub www() Dim s&, c s = Cells(Rows.Count, 1).End(xlUp).Row With ActiveSheet.Range("$A$1:$A$" & s) .RemoveDuplicates Columns:=1, Header:=xlNo .Hyperlinks.Delete End With s = Cells(Rows.Count, 1).End(xlUp).Row For Each c In ActiveSheet.Range("$A$1:$A$" & s) c.Value = c.Value & ";" Next c End Sub
[/vba]
[vba]
Code
Sub www() Dim s&, c s = Cells(Rows.Count, 1).End(xlUp).Row With ActiveSheet.Range("$A$1:$A$" & s) .RemoveDuplicates Columns:=1, Header:=xlNo .Hyperlinks.Delete End With s = Cells(Rows.Count, 1).End(xlUp).Row For Each c In ActiveSheet.Range("$A$1:$A$" & s) c.Value = c.Value & ";" Next c End Sub
Sub www() Dim vItem, avArr, li As Long ReDim avArr(1 To Rows.Count, 1 To 1) With New Collection On Error Resume Next For Each vItem In Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value .Add vItem, CStr(vItem) If Err = 0 Then li = li + 1: avArr(li, 1) = vItem & ";" Else: Err.Clear End If Next End With Range("A1", Cells(Rows.Count, 1).End(xlUp)).Clear [a1].Resize(li).Value = avArr End Sub
Sub www() Dim vItem, avArr, li As Long ReDim avArr(1 To Rows.Count, 1 To 1) With New Collection On Error Resume Next For Each vItem In Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value .Add vItem, CStr(vItem) If Err = 0 Then li = li + 1: avArr(li, 1) = vItem & ";" Else: Err.Clear End If Next End With Range("A1", Cells(Rows.Count, 1).End(xlUp)).Clear [a1].Resize(li).Value = avArr End Sub