Всем доброго времени суток. Прошу помощи в написании макроса. Имеется огромный документ, в котором наименование источников необходимо привести к "ссылочному" варианту. Вручную перебирать более 1500 источников было бы крайне утомительно, да и задача время от времени возникает.
В документе .docx (хотя задача может быть решена и для текста в ячейке A1 в документе .xlsx) необходимо найти первый фрагмент, заключенный между служебными словами ref и заменить такой фрагмент во всем тексте на [1] и т.д.
Было: ref[ivanov-14]ref, тут текст ref[!VasilyevMA]ref еще текст [text], ref[ivanov-14]ref Стало: [1], тут текст [2] еще текст [text], [1]
Другими словами, произвести замену элементов по всему тексту на порядковые номера, по порядку следования.
Sub ReplaceText()
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
.Replacement.Text = ""
Do While .Execute(FindText:="\[*\]", MatchWildcards:=True)
.Execute FindText:="[[\] ]", MatchWildcards:=True, _
ReplaceWith:="", Replace:=wdReplaceAll, Wrap:=wdFindStop
Loop
End With
Application.ScreenUpdating = True
End Sub
Задача решена практически на 99%, для этого пришлось все ссылки обрамить служебными словами: ref[ссылка]ref, однако зачастую программа "проскакивает" некоторые элементы и в результате нарушается порядок: [1], [2], [4], [5] ... Не мог бы кто-нибудь подсказать, как пофиксить баг?
Код
Sub findTest()
Application.ScreenUpdating = False
Dim firstTerm As String
Dim secondTerm As String
Dim myRange As Range
Dim documentText As String
Dim startPos As Long 'Stores the starting position of firstTerm
Dim stopPos As Long 'Stores the starting position of secondTerm based on first term's location
Dim nextPosition As Long 'The next position to search for the firstTerm
Application.ScreenUpdating = False
nextPosition = 1
'Get all the document text and store it in a variable.
Set myRange = ActiveDocument.Range
documentText = myRange.Text
i = 1
With Selection.Find
Do While .Execute(FindText:="ref[")
Selection.HomeKey Unit:=wdStory
'First and Second terms as defined by your example. Obviously, this will have to be more dynamic
'if you want to parse more than justpatientFirstname.
firstTerm = "ref["
secondTerm = "]ref"
startPos = InStr(nextPosition, documentText, firstTerm, vbTextCompare)
stopPos = InStr(startPos, documentText, secondTerm, vbTextCompare)
myString = Mid$(documentText, startPos + Len(firstTerm), stopPos - startPos - Len(firstTerm))
myString2 = "ref[" & myString & "]ref"
nextPosition = InStr(stopPos, documentText, firstTerm, vbTextCompare)
myRange.Find.Execute FindText:=myString2, ReplaceWith:="[" & i & "]", Replace:=wdReplaceAll
i = i + 1
Loop
End With
Application.ScreenUpdating = True
End Sub
Function RepRef$(s$)
Dim re, ms, m, i&
Set re = CreateObject("VBScript.RegExp")
re.Global = True: re.MultiLine = True: re.Pattern = "ref\[[^]]+\]ref"
If re.test(s) Then
Set ms = re.Execute(s)
For Each m In ms
i = i + 1: s = Replace(s, m, "[" & i & "]")
Next
End If
RepRef = s
End Function
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
это не ошибка это ОТСУТСВИЕ обьяснений задачи где должно быть человеческим языком сказано что делать если в данных есть одинаковые ссылки все что вы не обьяснили, но очень сильно об этом думали - осталось в ваших мыслях и ни одним словом не коснулось меня исправляйте самостоятельно)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
написал: это не ошибка это ОТСУТСВИЕ обьяснений задачи где должно быть человеческим языком сказано что делать если в данных есть одинаковые ссылки все что вы не обьяснили, но очень сильно об этом думали - осталось в ваших мыслях и ни одним словом не коснулось меня исправляйте самостоятельно)
Вот именно что предусмотрел, даже дважды в тексте отобразил.
Первый раз:
"необходимо найти первый фрагмент, заключенный между служебными словами ref и заменить такой фрагмент во всем тексте на [1] и т.д."
Внимание вопрос (глядя на эту фразу), ссылка может встречаться в тексте более чем один раз?
А второй раз даже пример привел, если Вы вдруг не заметили, аккурат с "одинаковыми ссылками":
Было: ref[ivanov-14]ref, тут текст ref[!VasilyevMA]ref еще текст [text], ref[ivanov-14]ref Стало: [1], тут текст [2] еще текст [text], [1]
Тем не менее, просто по человечески благодарю за проявленный интерес к проблеме.
Да, я не мог понять, что Replace не производит замену в исходном, анализируемом тексте "documentText", а стало быть, натыкается в последующем на ранее найденные ref[*]ref и проводит итерацию i = i +1 но без преобразования значения. Это я смог понять после Вашего поста о "одинаковых ссылках". Уже думал создавать массив с "ранее встречавшимися" ссылками, с последующей проверкой. Да, это решает проблему, вопрос закрыт:
Цитата
написал: 1If InStr(s, m) Then i = i + 1: s = Replace(s, m, "[" & i & "]")
Еще раз, огромное человеческое спасибо, Вы очень и очень выручили!!!!
Option Explicit
Sub abcdf()
Dim i As Long, fnd As String, rplc As String, txtrng As Object
Selection.HomeKey Unit:=wdStory
Set txtrng = ActiveDocument.Range
txtrng.Find.ClearFormatting
txtrng.Find.Replacement.ClearFormatting
Do While txtrng.Find.Execute(FindText:="ref\[*\]ref", MatchWildcards:=True)
i = i + 1
rplc = "[" & i & "]"
fnd = ActiveDocument.Range(Start:=txtrng.Start, End:=txtrng.End).Text
txtrng.Find.Execute FindText:=fnd, MatchWholeWord:=True, MatchWildcards:=False, _
Forward:=True, Wrap:=wdFindContinue, ReplaceWith:=rplc, _
Replace:=wdReplaceAll
Loop
End Sub