1 Востаннє редагувалося Григорій2 (10.02.2015 08:14:32)

Тема: Маю напрацювання в VBA/Word, Excel, куди кидати?

Хлопці/дівчата!
Працюю в VBA/Word/Excel
Маю напрацювання, хочу поділитись, може кому пригодиться
Ось зараз зіткнувся з зворотньою нумерацією в Wordі, як таблиці чи тексту
Куди кидати?

Chemist-i:

Зворотня нумерація тексту MS Word: (Завантажити файл)

Опис

Зворотна нумерація для списку виділеного тексту.
Макрос1-Alt+Ctrl+.            (Alt – права кнопка)
Виділений текст вставляє в таблицю і нумерує в оберненому порядку

Макрос2-Alt+Ctrl+є            (Alt – права кнопка)
Виділений текст нумерує в оберненому порядку

Або макроси можна викликати через Alt+F8

Як виглядає

До натискання
https://replace.org.ua/extensions/om_images/img/54d983e77cc24/e3h8tmrt6zf1.png

Після натискання
https://replace.org.ua/extensions/om_images/img/54d983e77cc24/o86b0p562p8a.png

Код VB
Sub Макрос1()
Dim Numrange As Range
Dim numtable As Table
Dim numcolumn As Column
Dim tabwidth As Long
Dim i As Long
  Set Numrange = Selection.Range
  Set numtable = Numrange.ConvertToTable(Separator:=vbCr)
  tabwidth = PointsToInches(numtable.Columns(1).Width)
  Set numcolumn = Numrange.Tables(1).Columns.Add(BeforeColumn:=numtable.Columns(1))
  numcolumn.Width = InchesToPoints(0.5)
  numtable.Columns(2).Width = InchesToPoints(tabwidth - 0.5)
  For i = 1 To numcolumn.Cells.Count
    numcolumn.Cells(i).Range.InsertBefore (numcolumn.Cells.Count - i + 1) & "."
  Next i
  numtable.Borders.Enable = False
lbl_Exit:
  Exit Sub
End Sub
Sub Макрос()
  Dim i As Long
Dim listCount As Long
Dim Numrange As Range
Dim oTmpRng As Range
  Set Numrange = Selection.Range
  ActiveWindow.View.ShowFieldCodes = False
  Numrange.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.3)
  listCount = Numrange.Paragraphs.Count
  For i = 1 To listCount
    Set oTmpRng = Numrange.Paragraphs(i).Range
    If IsNumeric(oTmpRng.Characters(1)) Then
      On Error GoTo ErrHandler
      If InStr(oTmpRng.Fields(1).Code, "SEQ") > 0 Then
        oTmpRng.Fields(1).Delete
        oTmpRng.End = oTmpRng.Start + 2
        oTmpRng.Delete
      End If
    End If
Reentry:
    Set oTmpRng = Numrange.Paragraphs(i).Range
    oTmpRng.Collapse wdCollapseStart
    oTmpRng.InsertAfter "." & vbTab
    oTmpRng.End = oTmpRng.End - 2
    If i = 1 Then
      Numrange.Fields.Add oTmpRng, wdFieldSequence, "ReverseList \r1", False
    Else
      Numrange.Fields.Add oTmpRng, wdFieldSequence, "ReverseList", False
    End If
    oTmpRng.End = oTmpRng.End + 1
    Numrange.Fields.Add oTmpRng, wdFieldEmpty, , False
    oTmpRng.End = oTmpRng.End - 1
    oTmpRng.InsertAfter Text:="=" & listCount + 1 & "-"
    With Numrange.Paragraphs(i)
      .LeftIndent = InchesToPoints(0.3)
      .FirstLineIndent = InchesToPoints(-0.3)
    End With
  Next i
  ActiveWindow.View.ShowFieldCodes = False
  ActiveDocument.Fields.Update
  Exit Sub
ErrHandler:
  If Err.Number = 5941 Then
    Set oTmpRng = Nothing
    Resume Reentry
  Else
    MsgBox "Unknown error exiting this routine"
  End If
End Sub

Зворотня нумерація таблиці MS Word (Завантажити файл)

Опис

1) Зворотньо номерує 1-й стовбець
2) При вставці / видаленні строк кнопкою "Перенумерувати", переномерує наново.
Можна призначити роботу макроса комбінацією клавіш. Тоді кнопку "Перенумерувати" можна видалити

Як виглядає

https://replace.org.ua/extensions/om_images/img/54d983e77cc24/09zpt6cr0bgd.png

Код VB
Private Sub CommandButton1_Click()
    Set Table = Range.Tables(1)
    countColumn = Table.Columns.Count
    countRow = Table.Rows.Count
    For i = 2 To countRow
    Table.Cell(i, 1) = countRow - i + 1
    Next i
End Sub

Використання форми в MS Word (Завантажити файл)

Опис

1) Жовтим виділено дані, які вставляються/міняються формою
2) Вставлені формули, які розраховують необхідні параметри
3) решта питань на форумі
4) Якщо треба, видаліть цю підказку

Як виглядає

Форма
https://replace.org.ua/extensions/om_images/img/54d983e77cc24/hnjh6w16qeun.png

Документ
https://replace.org.ua/extensions/om_images/img/54d983e77cc24/am52sdksot3j.png

Код VB
'Private Sub ComboBox1_Change()
'End Sub
'Private Sub ComboBox1_Click()
''Set bm = ActiveDocument.Bookmarks
''ComboBox1.RowSource = bm("таблиця").Range
'End Sub
'Private Sub ComboBox1_Enter()
'ComboBox1.AddItem "175"
'ComboBox1.AddItem "Left Top"
'ComboBox1.AddItem "210"
'End Sub
'Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'End Sub
Private Sub Label1_Click()
МаркаПроводу.Value = "АС-50"
End Sub
Private Sub Label12_Click()
tbDate.Text = ""
End Sub

Private Sub Label6_Click()
ДопустСтрум.Text = 210
End Sub

Private Sub ListBox1_Click()

End Sub

Private Sub tbDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
tbDate.Text = Format(Date, "dd mm yyyy")
End Sub

Private Sub tbDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Not IsDate(tbDate.Text) Then 'если данные введены не в формате даты, то
    MsgBox "Дата введена неправильна або без дати"   'выводим сообщение
    '        Exit Sub
End If
End Sub

Private Sub ВставитиДані_Click()
'Дії форми при натиску кнопки "ВставитиДані"
Dim bm As Bookmarks
Dim rng As Word.Range
Dim addr As String
Dim sText As String
Dim sResult1 As String
Dim sResult2 As String
Dim arName() As String  'объявляем динамический массив из строки "Имя адресата"

Set bm = ActiveDocument.Bookmarks
'Дії з полями
With tbDate
MyPos = InStr(1, (.Text), "р")    ' Returns 0 коли нема "р".
    If (.Text) = "" Then
    Set rng = bm("дата5").Range
    rng.Text = "____________"
    bm.Add "дата5", rng
    End If
        Set rng = bm("дата5").Range 'присваиваем переменной rng ссылку на закладку "дата5"
        If MyPos = 0 Then
            rng.Text = tbDate & " р."    ' текст закладки з "р".
            Else
            rng.Text = tbDate   ' текст закладки без "р".
        End If
        bm.Add "дата5", rng 'вставляєм текст в закладку
End With
    Set rng = bm("ДозволенаПотужність5").Range
    rng.Text = МаксРозрахНавант
    bm.Add "ДозволенаПотужність5", rng
Set rng = bm("обєкт5").Range
rng.Text = ОбєктАдресЗаявник
bm.Add "обєкт5", rng
    Set rng = bm("провід5").Range
    rng.Text = МаркаПроводу
    bm.Add "провід5", rng
Set rng = bm("точкаЗабезп5").Range
rng.Text = ТочкаЗабезп
bm.Add "точкаЗабезп5", rng
    Set rng = bm("напруга5").Range
    rng.Text = Напруга
    bm.Add "напруга5", rng
Set rng = bm("СтрумПровода5").Range
rng.Text = ДопустСтрум
bm.Add "СтрумПровода5", rng
    Set rng = bm("ПС_110або35").Range
    rng.Text = Підстанція
    bm.Add "ПС_110або35", rng
Set rng = bm("ПотужнПоДогов5").Range
rng.Text = ПотужнПоДогов
bm.Add "ПотужнПоДогов5", rng
    Set rng = bm("фідер5").Range
    rng.Text = НомерФідера
    bm.Add "фідер5", rng
Set rng = bm("МаксимальнеНавантаження5").Range
rng.Text = МаксНавантОЗП
bm.Add "МаксимальнеНавантаження5", rng
    Set rng = bm("Заявник5").Range
    rng.Text = Заявник
    bm.Add "Заявник5", rng
Set rng = bm("резервПотужн5").Range
rng.Text = РезервПотужн
bm.Add "резервПотужн5", rng

'Set rng = bm("name").Range 'присваиваем переменной rng ссылку на закладку "name"
'sResult1 = arName(0) & " " 'присваиваем переменной значение первого слова из поля "Имя адресата" и _
'                            добавляем пробел
'sResult1 = sResult1 & Left(arName(1), 1) & ". " 'добавляем к первому слову первую букву Имени и точку
'sResult1 = sResult1 & Left(arName(2), 1) & "."  'добавляем первую букву Отчества и точку
'rng.Text = sResult1  'определяем новый текст закладки
'bm.Add "name", rng   'заменяем закладку
Unload Me   'Закрываем форму
    Selection.WholeStory ' Виділити все
ActiveDocument.Range.Fields.Update  'Обновляем все поля в документе
Selection.HomeKey Unit:=wdStory
End Sub

Private Sub CommandButton2_Click()
'Выход из формы и закрытие окна документа при нажатии кнопки "Отменить"
On Error GoTo ErrLabel
Unload Me    'Закрываем форму
'ActiveDocument.Close  'Закрываем текущий документ
ErrLabel:
End Sub

Private Sub TextBox2_Change()
'Устанавливаем правила заполнения поля "Индекс"
With tbIndex
   If Not IsNumeric(.Text) Or Len(.Text) <> 6 Then 'если в поле "Индекс" данные не цифры и меньше 6, то
      MsgBox "Ошибка!" & " " & "Введите 6 цифр индекса города или района." 'выводим сообщение
      Cancel = True  'возвращаемся к полю
      .Text = ""  'очищаем поле
      .SetFocus
   End If
End With
End Sub
Private Sub tbName_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'При выходе из поля "Имя адресата" его имя подставляется в поле "Приветствие"

sText = tbName.Text
arName = Split(sText)
'sResult2 = arName(1) & " "
'sResult2 = sResult2 & arName(2)

tbSalutation = "Уважаемый " & sResult2 & "!"

End Sub
Private Sub UserForm_Initialize()
Set bm = ActiveDocument.Bookmarks
ОбєктАдресЗаявник = bm("обєкт5").Range
МаксРозрахНавант = bm("ДозволенаПотужність5").Range
МаркаПроводу = bm("провід5").Range
ТочкаЗабезп = bm("точкаЗабезп5").Range
Напруга = bm("напруга5").Range
ДопустСтрум = bm("СтрумПровода5").Range
Підстанція = bm("ПС_110або35").Range
ПотужнПоДогов = bm("ПотужнПоДогов5").Range
НомерФідера = bm("фідер5").Range
МаксНавантОЗП = bm("МаксимальнеНавантаження5").Range
Заявник = bm("Заявник5").Range
tbDate = bm("дата5").Range
РезервПотужн = bm("резервПотужн5").Range
End Sub
Private Sub UserForm_Click()

End Sub
Private Sub МаксНавантПЛ_Change()

End Sub

Private Sub ДопустСтрум_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
End Sub

Private Sub Заявник_Change()

End Sub

Private Sub МаксРозрахНавант_Change()

End Sub
Private Sub МаркаПроводу_Change()
МаркаПроводу.List = Array("АС-35", "АС-50", "А-35", "А-50")
Number = МаркаПроводу.ListIndex
B = МаркаПроводу.List(Number)
Select Case Number
Case 0
ДопустСтрум.Text = 175
Case 1
ДопустСтрум.Text = 210
Case 2
ДопустСтрум.Text = 170
Case 3
ДопустСтрум.Text = 215
End Select
End Sub

Private Sub МаркаПроводу_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
МаркаПроводу.Value = "АС-35"
End Sub

Private Sub МаркаПроводу_Enter()

End Sub

Private Sub напруга_Change()
НомерФідера = Напруга.Value & " кВ №"
End Sub

Private Sub НомерФідера_Change()

End Sub
Private Sub Підстанція_Change()
Підстанція.List = Array("ПС 110/35/10 кВ ''Хххххх''", "ПС 110/35/10 кВ ''Еееее''", "ПС 35/10 кВ ''Іііі''", _
"ПС 35/10 кВ ''Ввввв''", "ПС 35/10 кВ ''Ооооо''", "ПС 35/10 кВ ''Оріховець''", "ПС 35/10 кВ ''Рррррр''", _
"ПС 35/10 кВ ''Ааааа''", "ПС 35/10 кВ ''Ссссс''")
End Sub

Private Sub ПотужнПоДогов_Change()

End Sub

Private Sub ТочкаЗабезп_Change()

End Sub

Вічний календар MS Excel (Завантажити файл)

Як виглядає

https://replace.org.ua/extensions/om_images/img/54d983e77cc24/gd035sw494xz.png

На жаль код VB захищений паролем (прим. Chemist-i)


Розрахунок товщини провідника MS Excel (Завантажити файл)

Як виглядає

https://replace.org.ua/extensions/om_images/img/54d983e77cc24/qlygermgut8m.png

Подякували: Chemist-i, leofun01, iovchynnikov3

2

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Сюди і кидайте, тіки оформіть все красиво

3

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Я тут вперше, на російські форуми не хочу кидати
Де тут опція прикріпити файл?

4

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Натисніть "відповісти" і внизу зможете прикріпити файл. Але сам код раджу викласти в теґ code. Отак:

кід кід кід

5

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Ось

6

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Мабуть ви обрали файл, а не додали його. Там кнопка є в тому ж рядку, що і вибір файла.

7

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

2 ще

Post's attachments

Зворотня нумерація тексту.doc 49 kb, 664 downloads since 2015-02-09 

Подякували: 0xDADA11C7, leofun012

8 Востаннє редагувалося Григорій2 (09.02.2015 15:13:55)

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

3 ще

Post's attachments

Зворотня нумерація таблиці.doc 53.5 kb, 619 downloads since 2015-02-09 

Подякували: 0xDADA11C7, leofun012

9

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

А тепер оформіть все по-людськи - з кодом в спойлерах і описами макросів

10

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Нащо лишнє писати?
Всі коди макросів можете подивитись, натиснувши
комбінацію клавіш Alt+F11

11

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

А тепер ще файл
Там внизу є коротке пояснення

Post's attachments

Використання форми в Ворд.doc 143 kb, 807 downloads since 2015-02-09 

12 Востаннє редагувалося Григорій2 (09.02.2015 16:27:38)

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

"Вічний" календар
(тільки жовтим підсвічує дні народження моє та близьких)
Міняєте тільки рік

Post's attachments

Вічний календар.xls 45.5 kb, 615 downloads since 2015-02-09 

Подякували: leofun011

13

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Взагалі то я по професії інженер-електрик, кінчив Львівску політехніку
А програмування хоббі
Викладаю свій файл вибору перерізу провідників

Post's attachments

Розрахунок перерізу провідника.xls 69 kb, 634 downloads since 2015-02-09 

Подякували: leofun011

14

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Дякую за ваш внесок -- я оформлю ваші проекти, а ви візьмете цей стиль за взірець, щоб знати як оформити наступного разу ваш. Домовилися?

Нащо лишнє писати?

Бо гугл, бо зручно не завантажувати файл а одразу дивитися код.

15

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Так як 0xDADA11C7 є пророком Лінупса, мабуть в нього нема MS Office, але в мене є.

Григорій2, відредагував Ваше перше повідомлення. Особисто від мене дякую за Ваш внесок, принаймні один документ мені сі знадобить найближчим часом.

16

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Дякую за підтримку 0xDADA11C7, Chemist-i

Висилаю файл
Код можна проглянути натиснувши комбінацію  Alt+F11

Post's attachments

Вибір унікальних значень.xls 70 kb, 514 downloads since 2015-02-10 

Подякували: leofun011

17

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Висилаю файл
Код можна проглянути натиснувши комбінацію  Alt+F11

Post's attachments

Розбивка тексту.xls 57.5 kb, 761 downloads since 2015-02-10 

Подякували: leofun011

18 Востаннє редагувалося Григорій2 (12.02.2015 14:27:50)

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Див.файл

Post's attachments

Розбивка тексту в стовпчик.xls 33 kb, 565 downloads since 2015-02-12 

19

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

а паролі?

20

Re: Маю напрацювання в VBA/Word, Excel, куди кидати?

Djalin написав:

а паролі?

Де саме?
Там без паролів