копирование Гиперссылки. vba

[ZlodeiDen]

Уважаемые форумчане!
помогите решить задачку.
пользуюсь данной процедурой:

Option Explicit

Sub test()
    Dim rngTable As Range   'Main Table range
    Dim rngCol As Range     'Column which contains organizations names
    Dim rngList As Range    'Range where organizations list is copied
    Dim rngCrit As Range    'Cell which contains organization name for filtering
    Dim i As Long           'Counter
    
    'Set variables
    With Sheets("Data")
        On Error GoTo ErrHandler
        Set rngTable = .Range(Application.InputBox _
            (prompt:="Select a cell in the first data row:", Type:=8).EntireRow.Cells(1), Intersect( _
            .Cells.Find("*", .Cells(1), xlValues, xlWhole, xlByRows, xlPrevious).EntireRow, _
            .Cells.Find("*", .Cells(1), xlValues, xlWhole, xlByColumns, xlPrevious).EntireColumn))
        'Ask the user to choose the column with Organizations
        Set rngCol = Intersect(rngTable, Application.InputBox _
            (prompt:="Select a cell in the Organization column:", Type:=8).EntireColumn)
        On Error GoTo 0
    Application.ScreenUpdating = False
    End With
    Set rngList = Sheets("List").[A1]
    Set rngCrit = Sheets("Criteria").[A2]
    
    'Renew the organizations list (unique)
    rngList.CurrentRegion.ClearContents
    rngCol.AdvancedFilter xlFilterCopy, , rngList, True
    Set rngList = rngList.CurrentRegion
    
    'Clear the creteria cell
    rngCrit.ClearContents
    
    'Create new workbooks with the name of the organization
    For i = 2 To rngList.Count
        rngCrit.FormulaR1C1 = _
            "=" & rngCol(1).Address(False, False, xlR1C1, True) & "=""" & rngList(i) & """"
        With Workbooks.Add
            With .Sheets(1)
                rngTable.AdvancedFilter xlFilterCopy, rngCrit.Offset(-1).Resize(2), .[A1]
                rngTable.Parent.Rows("1:3").Copy
                .Rows("1:1").Insert Shift:=xlDown
                .UsedRange.EntireColumn.AutoFit
            End With
            Application.DisplayAlerts = False
            .SaveAs ThisWorkbook.Path & "\" & rngList(i) & ".xlsx"
            Application.DisplayAlerts = True
            .Close True
        End With
    Next i
ErrHandler:
Application.ScreenUpdating = True
End Sub

столкнулся с проблемой, данный код не умеет копировать в новую книгу гиперссылки((( копирует только текст описание для ссылки.
потратил день, а проблему не решил, оказалось не по зубам проблема. вся надежда на вас)))
выручайте! в каком направлении двигаться?

[Казанский]

Необходим файл-пример, в т.ч. с гиперссылками.

[ZlodeiDen]

Сообщение от Казанский

Необходим файл-пример, в т.ч. с гиперссылками.

извиняюсь, забыл выложить пример.
В файле тест, примерная таблица с гиперссылками, её нужно разбить на 3 файла, с этим проблем нет. но почему-то теряются гиперссылки, остаётся только "текст описание" см. файлы Москва, СПб, Сочи.

[Казанский]

Здесь удобнее автофильтр, а уникальные выделять на коллекции.

Option Explicit

Sub test()
Dim rngTable As Range       'Main Table range
Dim rngCol As Range         'Column which contains organizations names
Dim rngList As Range        'Range where organizations list is copied
Dim rngCrit As Range        'Cell which contains organization name for filtering
Dim i As Long               'Counter

'Set variables
    On Error GoTo ErrHandler
    With Sheets("Data")
        Set rngTable = .Range(Application.InputBox _
            (prompt:="Select a cell in the first data row:", Type:=8).EntireRow.Cells(1), Intersect( _
            .Cells.Find("*", .Cells(1), xlValues, xlWhole, xlByRows, xlPrevious).EntireRow, _
            .Cells.Find("*", .Cells(1), xlValues, xlWhole, xlByColumns, xlPrevious).EntireColumn))
        'Ask the user to choose the column with Organizations
        Set rngCol = Intersect(rngTable, Application.InputBox _
            (prompt:="Select a cell in the Organization column:", Type:=8).EntireColumn)
        Application.ScreenUpdating = False
    End With
    On Error Resume Next
    Dim cl As New Collection, x    'move to declarations block
    With rngTable.Offset(-1).Resize(rngTable.Rows.Count + 1)    'table with header
        For Each x In rngCol.Value
            cl.Add 0, CStr(x)
            If Err Then
                Err.Clear
            Else
                .AutoFilter rngCol.Column - rngTable.Column + 1, x
                With Workbooks.Add
                    With .Sheets(1)
                        rngTable.Worksheet.Cells.SpecialCells(xlCellTypeVisible).EntireRow.Copy .[A1]
                        .UsedRange.EntireColumn.AutoFit
                    End With
                    Application.DisplayAlerts = False
                    .SaveAs ThisWorkbook.Path & "\" & x & ".xlsx"
                    Application.DisplayAlerts = True
                    .Close False    'True
                End With
            End If
        Next x
        .AutoFilter
    End With

ErrHandler:
    Application.ScreenUpdating = True
    End Sub