Преобразование текст-код поля в ячейках столбца таблицы

[Rybakot]

Есть макрос преобразующий текстовые строки (типа { =D9-C9 \# "0,000" }) в коды поля. Замечательно работает по обычному списку строк (друг под другом), но не работает в ячейках столбца таблицы. Работает только с одной ячейкой, текст в каждой ячейке надо выделить и запустить макрос. Если строк (ячеек) много, то это довольно утомительно, а иногда и физически невозможно. Просьба модернизировать, подправить код макроса, чтобы он проходился по всем ячейкам столбца. Спасибо.

Sub FieldStringToCode()
' На основе макроса, предоставленного Полом Эдштейном
' Преобразует "текстовые" коды полей в реальные коды полей
' Чтобы выполнить преобразование, просто вставьте "текстовые" коды полей
' в свой документ, выберите их и запустите макрос.
Dim RngFld As Range
Dim RngTmp As Range
Dim oFld As Field
Dim StrTmp As String
Dim sUpdate As String
Dim bFldCodes As Boolean
Const Msg1 = "Выделите текст для преобразования и попробуйте снова"
Const Msg2 = "В выбранном диапазоне нет строк полей"
Const Msg3 = "В выбранном диапазоне нет одинаковых пар фигурных скобок полей"
Const Title1 = "Ошибка!"
Const Title2 = "Обновить поля?"
Application.ScreenUpdating = False
bFldCodes = ActiveDocument.ActiveWindow.View.ShowFieldCodes
If Selection.Type <> wdSelectionNormal Then
MsgBox Msg1, vbExclamation + vbOKOnly, Title1
Exit Sub
End If
If InStr(1, Selection.Text, "{") = 0 Or InStr(1, Selection.Text, "}") = 0 Then
MsgBox Msg2, vbCritical + vbOKOnly, Title1
End If
If Len(Replace(Selection.Text, "{", vbNullString)) <> Len(Replace(Selection.Text, "}", vbNullString)) Then
MsgBox Msg3, vbCritical + vbOKOnly, Title1
Exit Sub
End If
ActiveDocument.ActiveWindow.View.ShowFieldCodes = True
Set RngFld = Selection.Range
With RngFld
.End = .End + 1
Do While InStr(1, .Text, "{") > 0
Set RngTmp = ActiveDocument.Range(Start:=.Start + InStr(.Text, "{") - 1, End:=.Start + InStr(.Text, "}"))
With RngTmp
Do While Len(Replace(.Text, "{", vbNullString)) <> Len(Replace(.Text, "}", vbNullString))
.End = .End + 1
If .Characters.Last.Text <> "}" Then .MoveEndUntil cset:="}", Count:=Len(ActiveDocument.Range(.End, RngFld.End))
Loop
.Characters.First = vbNullString
.Characters.Last = vbNullString
StrTmp = .Text
Set oFld = ActiveDocument.Fields.Add(Range:=RngTmp, Type:=wdFieldEmpty, Text:="", PreserveFormatting:=False)
oFld.Code.Text = StrTmp
End With
Loop
ActiveDocument.ActiveWindow.View.ShowFieldCodes = bFldCodes
.End = .End - 1
If bFldCodes = False Then .Fields.ToggleShowCodes
.Select
End With
Application.ScreenUpdating = True
sUpdate = MsgBox("Вы хотите обновить поля?" & vbCr + vbCr & _
"Обратите внимание, что если преобразованные поля включают поля ЗАПРОСА или заполнения" & _
"обновление принудительно вызовет запрос на ввод в эти поля", vbYesNo, Title2)
If sUpdate = vbYes Then RngFld.Fields.Update
Set RngTmp = Nothing
Set RngFld = Nothing
Set oFld = Nothing
End Sub

[Администратор]

Написал вам письмо на почту. Написал именно на почту, а не на форум.

[Rybakot]

Задачу решил с помощью ChatGPT. Лишние навороты убраны.

Макрос преобразует текст в выделенных ячейках столбца таблицы (похожий на код поля, формулу) в реальный код поля.

Sub FieldStringTableToCode()

ActiveDocument.ActiveWindow.View.ShowFieldCodes = True
Dim cell As Cell
Dim StrTmp As String
Dim oFld As Field

' Проходим по каждой выделенной ячейке
For Each cell In Selection.Cells
    Set RngFld = cell.Range
    With RngFld
        .End = .End + 1
        Do While InStr(1, .Text, "{") > 0
            Set RngTmp = ActiveDocument.Range(Start:=.Start + InStr(.Text, "{") - 1, End:=.Start + InStr(.Text, "}"))
            With RngTmp
                Do While Len(Replace(.Text, "{", vbNullString)) <> Len(Replace(.Text, "}", vbNullString))
                    .End = .End + 1
                    If .Characters.Last.Text <> "}" Then .MoveEndUntil cset:="}", Count:=Len(ActiveDocument.Range(.End, RngFld.End))
                Loop
                .Characters.First = vbNullString
                .Characters.Last = vbNullString
                StrTmp = .Text

                ' Добавляем новое поле
                Set oFld = ActiveDocument.Fields.Add(Range:=RngTmp, Type:=wdFieldEmpty, Text:="", PreserveFormatting:=False)
                oFld.Code.Text = StrTmp
            End With
        Loop
    End With
Next cell

' Обновляем состояние отображения полей после обработки всех ячеек
ActiveDocument.Fields.Update

End Sub