Sub Perenos()
Dim j As Integer
Dim iLR_A As Long
Dim iLastRow
  For j = 2 To 5
    iLR_A = Cells(Rows.Count, "A").End(xlUp).Row + 1
    iLastRow = Cells(Rows.Count, j).End(xlUp).Row
    Range(Cells(1, j), Cells(iLastRow, j)).Cut Cells(iLR_A, 1)
  Next
  iLR_A = Cells(Rows.Count, "A").End(xlUp).Row
  For j = iLR_A To 1 Step -1
    If IsEmpty(Cells(j, 1)) Then Rows(j).Delete
  Next
End Sub

Sub Макрос1()

Dim cell As Range
    For Each cell In Range("BG1:BG" & Cells(Rows.Count, "A").End(xlUp).Row) ' Указываю диапазон в котором нужно получить значения
    
Range("[@[Fk_Project]],[@Договор],,"" "",[@[Договор номер]").Merge ' Указываю в диапазон колонки умной таблицы для объединения
  
   Next cell

End Sub

Sub ConcatColuvns()
    Dim wSh As Worksheet
    Dim tbl As ListObject
    
    Set wSh = Sheets("Договоры")
    Set tbl = wSh.ListObjects("Договоры")


End Sub

Перед выполнением Регулярок будет Ваш макрос
Тогда после того ка появились нове договоры или обновили старые, мы получим в столбце BG актуальные данные;
Далее обработаем их RegExp для того что бы потом переименовать их под хранение на серваке.
Потом получим их ссылку и прикрепим к названию файла.
В итоге юзер открывая файл эксель, получит и реестр договоров и ссылку на сервер данных где этот договор лежит.

Поэтому мне обязательно нужно обновлять столбец данных.
А я пока вижу только ListObject только методы ADD? Application, Count, ...
Update не нахожу.


Sub ReplaceVWithGInColumn()
    Dim regEx As Object
    Dim cell As Range
    Dim originalText As String
    Dim resultText As String
    
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "[«»]"
    regEx.Global = True
    
    For Each cell In Range("BG1:BG" & Cells(Rows.Count, "A").End(xlUp).Row)
        If Not IsEmpty(cell.Value) Then
            originalText = cell.Value
            resultText = regEx.Replace(originalText, "")
            cell.Value = resultText
        End If
    Next cell
End Sub
Sub ReplaceVWithGInColumn1()
    Dim regEx As Object
    Dim cell As Range
    Dim originalText As String
    Dim resultText As String
    
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "[/]"
    regEx.Global = True
    
    For Each cell In Range("BG1:BG" & Cells(Rows.Count, "A").End(xlUp).Row)
        If Not IsEmpty(cell.Value) Then
            originalText = cell.Value
            resultText = regEx.Replace(originalText, "_")
            cell.Value = resultText
        End If
    Next cell
End Sub
Sub ReplaceVWithGInColumn2()
    Dim regEx As Object
    Dim cell As Range
    Dim originalText As String
    Dim resultText As String
    
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "\s{2,}"
    regEx.Global = True
    
    For Each cell In Range("BG1:BG" & Cells(Rows.Count, "A").End(xlUp).Row)
        If Not IsEmpty(cell.Value) Then
            originalText = cell.Value
            resultText = regEx.Replace(originalText, " ")
            cell.Value = resultText
        End If
    Next cell
End Sub

Sub ReplaceVWithGInColumn3()
    Dim regEx As Object
    Dim cell As Range
    Dim originalText As String
    Dim resultText As String
    
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "^\s+"
    regEx.Global = True
    
    For Each cell In Range("BG1:BG" & Cells(Rows.Count, "A").End(xlUp).Row)
        If Not IsEmpty(cell.Value) Then
            originalText = cell.Value
            resultText = regEx.Replace(originalText, "")
            cell.Value = resultText
        End If
    Next cell
End Sub

Sub Reg()
Call ReplaceVWithGInColumn
Call ReplaceVWithGInColumn1
Call ReplaceVWithGInColumn2
Call ReplaceVWithGInColumn3
End Sub

Sub Perenos()
Dim j As Integer
Dim iLR_A As Long
Dim iLastRow
  For j = 2 To 5
    iLR_A = Cells(Rows.Count, "A").End(xlUp).Row + 1
    iLastRow = Cells(Rows.Count, j).End(xlUp).Row
    Range(Cells(1, j), Cells(iLastRow, j)).Cut Cells(iLR_A, 1)
  Next
  iLR_A = Cells(Rows.Count, "A").End(xlUp).Row
  For j = iLR_A To 1 Step -1
    If IsEmpty(Cells(j, 1)) Then Rows(j).Delete
  Next
End Sub

Sub Perenos()
Const D = "D"
Dim j As Variant
Dim iLR_A As Long
Dim iLastRow As Long
  For Each j In Array(2, 4)
    iLR_A = Cells(Rows.Count, D).End(xlUp).Row + 1
    iLastRow = Cells(Rows.Count, j).End(xlUp).Row
    Range(Cells(1, j), Cells(iLastRow, j)).Cut Cells(iLR_A, D)
  Next
  iLR_A = Cells(Rows.Count, D).End(xlUp).Row
  For j = iLR_A To 1 Step -1
    If IsEmpty(Cells(j, D)) Then Rows(j).Delete
  Next
End Sub

Sub Perenos()
Const H = "H"
Dim j As Variant
Dim iLR_A As Long
Dim iLastRow As Long
  For Each j In Array(2, 4)
    iLR_A = Cells(Rows.Count, H).End(xlUp).Row + 1
    iLastRow = Cells(Rows.Count, j).End(xlUp).Row
    Range(Cells(1, j), Cells(iLastRow, j)).Copy Cells(iLR_A, H)
  Next
  iLR_A = Cells(Rows.Count, H).End(xlUp).Row
  For j = iLR_A To 2 Step -1
    If IsEmpty(Cells(j, H)) Then Cells(j, H).Delete
  Next
End Sub

Sub Perenos()
Const H = "H"
Dim j As Variant
Dim iLR_A As Long
Dim iLastRow As Long
  For Each j In Array(2, 4)
    iLR_A = Cells(Rows.Count, H).End(xlUp).Row + 1
    iLastRow = Cells(Rows.Count, j).End(xlUp).Row
    Range(Cells(1, j), Cells(iLastRow, j)).Copy Cells(iLR_A, H)
    Cells(iLR_A, H).Resize(iLastRow).Formula = Range(Cells(1, j), Cells(iLastRow, j)).Formula
  Next
  iLR_A = Cells(Rows.Count, H).End(xlUp).Row
  For j = iLR_A To 2 Step -1
    If IsEmpty(Cells(j, H)) Then Cells(j, H).Delete
  Next
End Sub