Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
28.03.2024, 13:54:24

Войти
Название темы должно отражать её содержание.
Темы типа "ПОМОГИТЕ!!!", "Срочно!", "Не получается сделать", "Нужна помощь" и т.п. будут удаляться без объяснения причин
33 233 Сообщений в 5 454 Тем от 6 750 Пользователей
Последний пользователь: Alex1210
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Word и VBA
| | |-+  запомнить позицию в документе
Страниц: [1]   Вниз
Печать
Автор Тема: запомнить позицию в документе  (Прочитано 7443 раз)
0 Пользователей и 1 Гость смотрят эту тему.
Dron_Spb
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 3


Просмотр профиля E-mail
« : 14.01.2018, 13:23:02 »

Всем привет!

Не могу никак осуществить запоминание и после действий восстановление точного места положения курсора в документе.
действия подразумевают перенос курсора в начало документа для поиска определенных сочетаний.
(если можно, то вплоть до положения на экране, чтобы пользователю не мелькало перед глазами)
пользовался GoTo,  но там удалось вернуться только на нужный лист, который до работы "Найти и заменить" был запомнен

Код: (vb)
'определение позиции
    PozX = Selection.Information(wdFirstCharacterColumnNumber)  '  позиция
    PozY = Selection.Information(wdFirstCharacterLineNumber)    '  строка
    Page_ = Selection.Information(wdActiveEndPageNumber)        '  страница


'  ***************   Действия   **********************

'  возврат на позиции
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=Page_ '  страница
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=PozY '  строка



подскажите как это лучше выполнить?
Спасибо.

« Последнее редактирование: 14.01.2018, 13:26:14 от Dron_Spb » Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #1 : 15.01.2018, 11:00:42 »

Неверным путем идете. Давайте начнем с другого: зачем нужно возвращаться? Вероятно, производятся какие-то действия кодом, которые перемещают курсор. Какие это действия и как выглядит код?
К чему спрашиваю: большинство действий можно сделать без перемещения курсора, следовательно отпадет необходимость возвращать его.
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Dron_Spb
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 3


Просмотр профиля E-mail
« Ответ #2 : 15.01.2018, 21:19:02 »

Неверным путем идете. Давайте начнем с другого: зачем нужно возвращаться? Вероятно, производятся какие-то действия кодом, которые перемещают курсор. Какие это действия и как выглядит код?
К чему спрашиваю: большинство действий можно сделать без перемещения курсора, следовательно отпадет необходимость возвращать его.

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

ниже привожу в текстовом формате код.

Код: (vb)

Sub Макрос_подсчет(Find_Text As String, Color_Fon As Integer, Counter As Long)

    Dim find_rng As Range, find As find
'    Dim Counter As Long
   
   
    '1. Откл. монитора.
    Application.ScreenUpdating = False
   
    '2. Создание объектов, которые будут искать.
    Set find_rng = ActiveDocument.Range(0, 0)
    Set find = find_rng.find
   
    '3. Настройка поиска.
    find.Text = Find_Text
    find.Wrap = wdFindStop
   
    '4. Поиск.
    Do While find.Execute = True
        '1) Закраска.
        find_rng.HighlightColorIndex = Color_Fon
        '2) Подсчёт, сколько найдено.
        Counter = Counter + 1
        '3) Превращение рейнджа в точку вставки и установка точки вставки после найденного фрагмента.
        find_rng.Collapse Direction:=wdCollapseEnd
    Loop
   
    '5. Вкл. монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
'    MsgBox "Найдено и закрашено: " & Counter, vbInformation
   
End Sub

Sub Procedure_1()

    Dim myFindRange As Word.Range
    Dim myFind As Word.find
   
    'Создаём диапазон, в котором будем искать.
    'ActiveDocument.Range - это основной текст в документе.
    'Есть ещё колонтитулы, сноски и другое.
    Set myFindRange = ActiveDocument.Range
   
    'Создаём объект "Find" и даём ему имя "myFind".
    Set myFind = myFindRange.find
   
    'Указываем, какой текст ищем.
    myFind.Text = "начальник"
   
    'Флажок "Подстановочные знаки".
    myFind.MatchWildcards = True
   
    'Курсив является форматированием.
    myFind.Format = True
   
'    Selection.Range.HighlightColorIndex = wdYellow
    myFind.Replacement.Font.ThemeColor = 2

    'Указываем, что сделать с найденным текстом.
'    myFind.Replacement.Font.Italic = True
   
    'Производим поиск и замену.
    myFind.Execute Replace:=wdReplaceAll
   
End Sub

Sub Проверить_пробелы_посленомера()
'
' Макрос6 Макрос
'
    Selection.find.ClearFormatting
    Selection.find.Replacement.ClearFormatting
    With Selection.find
        .Text = "№"
        .Replacement.Text = "№^s"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.find.Execute Replace:=wdReplaceAll
   
    Selection.find.ClearFormatting
    Selection.find.Replacement.ClearFormatting
    With Selection.find
        .Text = "^s "
        .Replacement.Text = "^s"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.find.Execute Replace:=wdReplaceAll
End Sub


Sub ReplaceMultiSpaces()
  Dim oChar As Range
  Dim kol As Integer
  For Each oChar In ActiveDocument.Characters
    If oChar.Text = " " Then
      While oChar.Next(wdCharacter).Text = " "
        oChar.Next(wdCharacter).Delete
        kol = kol + 1
      Wend
    End If
  Next
  If kol > 0 Then MsgBox "Убрано пробелов = " & kol Else MsgBox "Дубликатов пробелов не обнаружено"
End Sub


Sub Zamena_probelov(Poisk As String, Bufer As Integer, kol As Integer)
Dim Finish As Boolean

' Макрос6 Макрос
Finish = True
Selection.GoTo 1, 1

Do While Finish
    PozX = Selection.Information(wdFirstCharacterColumnNumber)
    PozY = Selection.Information(wdFirstCharacterLineNumber)
    Selection.find.ClearFormatting
    With Selection.find
        .Text = Poisk
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.find.Execute
   
    If Not (PozX = Selection.Information(wdFirstCharacterColumnNumber) And PozY = Selection.Information(wdFirstCharacterLineNumber)) Then
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.MoveRight Unit:=wdCharacter, Count:=Bufer + 1
        If Bufer > 0 Then Selection.TypeBackspace
        Selection.TypeText Text:=" "
        kol = kol + 1
    Else
        Finish = False
    End If
Loop
   
End Sub
Sub Probel_nomer()
Dim kol1 As Integer
Dim kol2 As Integer

    Application.ScreenUpdating = False

    kol1 = 0
    Zamena_probelov "№^$", 0, kol1
    Zamena_probelov "№^#", 0, kol1

    kol2 = 0
    Zamena_probelov "№ ^$", 1, kol2
    Zamena_probelov "№ ^#", 1, kol2
    MsgBox "Всего в тексте найдено '№':  " & kol2 & Chr(13) & " в т.ч. добавлено пробелов:  " & kol1
    Application.ScreenUpdating = True


End Sub

Sub Ubit_probel_data()
Dim kol As Integer
'   убирает пробелы в датах (меняя на сцепленные)
    kol = 0
'определение позиции
    PozX = Selection.Information(wdFirstCharacterColumnNumber)  '  позиция
    PozY = Selection.Information(wdFirstCharacterLineNumber)    '  строка
    Page_ = Selection.Information(wdActiveEndPageNumber)        '  страница

   
    Application.ScreenUpdating = False
    Zamena_probelov "^# январ", 1, kol
    Zamena_probelov "^# феврал", 1, kol
    Zamena_probelov "^# март", 1, kol
    Zamena_probelov "^# апрел", 1, kol
    Zamena_probelov "^# мая", 1, kol
    Zamena_probelov "^# июня", 1, kol
    Zamena_probelov "^# июля", 1, kol
    Zamena_probelov "^# авгус", 1, kol
    Zamena_probelov "^# сент", 1, kol
    Zamena_probelov "^# октя", 1, kol
    Zamena_probelov "^# нояб", 1, kol
    Zamena_probelov "^# декаб", 1, kol
    Zamena_probelov "20^#^# г.", 4, kol
    MsgBox "Заменено пробелов в датах: " & kol
   
'  возврат на позиции
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=Page_ '  страница
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=PozY '  строка
   
    Application.ScreenUpdating = True
End Sub
Sub Ubit_probel_OOO()
Dim kol As Integer
   
    Application.ScreenUpdating = False
    PozY = Selection.Information(wdFirstCharacterLineNumber)    '  строка
    Page_ = Selection.Information(wdActiveEndPageNumber)        '  страница
    kol = 0
    Zamena_probelov "ОАО ", 3, kol
    If kol > 0 Then MsgBox "Заменено пробелов в 'ОАО': " & kol
    kol = 0
    Zamena_probelov "ООО ", 3, kol
    If kol > 0 Then MsgBox "Заменено пробелов в 'ООО': " & kol
    kol = 0
    Zamena_probelov "ПАО ", 3, kol
    If kol > 0 Then MsgBox "Заменено пробелов в 'ПАО': " & kol
    kol = 0
    Zamena_probelov " АО ", 3, kol
    If kol > 0 Then MsgBox "Заменено пробелов в 'АО': " & kol
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=Page_ '  страница
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=PozY '  строка
    Application.ScreenUpdating = True
   
End Sub



Записан
Dron_Spb
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 3


Просмотр профиля E-mail
« Ответ #3 : 19.01.2018, 21:59:53 »

так есть у кого предложения для помощи??? В замешательстве
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #4 : 20.01.2018, 11:38:36 »

Нет желания вникать во все, что написано в коде и переделывать это под работу без выделения.
Вернуть к выделению можно так:
Код: (vb)

    If Selection.Editors.Count > 1 Then
        Selection.Editors.Item(1).DeleteAll
    End If
'запоминаем выделенную область
    Selection.Editors.Add wdEditorCurrent

'какой-то код

'выделяем изначально выделенную область документа с переходом
    ActiveDocument.Range.GoToEditableRange(wdEditorCurrent).Select
    Selection.Editors.Item(1).DeleteAll
« Последнее редактирование: 20.01.2018, 11:41:19 от The_Prist » Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru