Статьи из блога

Статьи из блога

Разбиение списка на части

Галина задала вопрос:

Есть список вопросов. Для разных дисциплин разное количество - от 30 до 60-ти. Их надо разделить пополам и соединить потом через один, то есть, при 60-ти вопросах нужно их объединить так: 1й и 31й, 2й и 32й... 30й и 60й. Просто вырезать и вставлять или копировать и вставлять - путаница, смещается нумерация, забываешь, какие вставила, какие нет. Можно как-то решить эту проблему?

Можно воспользоваться следующим макросом для разбиения списка на две части. Он нормально работает и с круглыми цифрами (50, 60) и четными некруглыми (52, 64). Для нечетных он оставляет в самом конце один повторный номер/вопрос.

Выделите ваш список и примените макрос:

Sub listM2()
'для четных чисел с разбиением на 2 части
Dim arr() As String
Dim arrF() As String
Dim arrS() As String
Dim rng As Range
Dim i As Long
Set rng = Selection.Range
rng.ListFormat.ConvertNumbersToText
arr = Split(rng, Chr(13))
For i = 0 To UBound(arr) / 2
    Selection.TypeText arr(i) & vbCrLf
    Selection.TypeText arr(i + (UBound(arr) / 2) - 1) & vbCrLf & vbCrLf
Next i
End Sub

Для разбиения списка на три части используйте следующий макрос:

Sub listM3()
'для разбиения на три части.
Dim arr() As String
Dim arrF() As String
Dim arrS() As String
Dim rng As Range
Dim i As Long
Set rng = Selection.Range
rng.ListFormat.ConvertNumbersToText
arr = Split(rng, Chr(13))
For i = 0 To UBound(arr) / 3
    Selection.TypeText arr(i) & vbCrLf
    Selection.TypeText arr(i + UBound(arr) / 3) & vbCrLf
    Selection.TypeText arr(i + 2 * UBound(arr) / 3) & vbCrLf & vbCrLf
Next i
End Sub
twitter.com facebook.com vkontakte.ru odnoklassniki.ru mail.ru ya.ru rutvit.ru myspace.com technorati.com digg.com friendfeed.com pikabu.ru blogger.com liveinternet.ru livejournal.ru memori.ru google.com bobrdobr.ru mister-wong.ru yahoo.com yandex.ru del.icio.us

Еще записи по вопросам использования Microsoft Word:

Комментариев: 12

  1. 13.01.2009 в 22:10 | #1

    Антон, как всегда блестяще. Нет слов. Только жаль, что список теряется.

  2. 14.01.2009 в 01:59 | #2

    Думаю Галине будет интересен такой вариант макроса для сортировки. Список не теряется. Сортирует как четное так и нечетное количество пунктов. После нескольких сортировок, примененных к одному и тому же списку, он очень хорошо перемешивается. Интересно, а в исходное состояние восстановится? Надо подумать. И за сколько сортировок?

    Sub ReArrangeList()
      Dim ListItem() As String
      Dim i, nParagCount As Integer
      Dim sOddOrEven As String
      With Selection
        ReDim ListItem(.Paragraphs.Count - 1) 'определяем размер массива
        For i = 0 To UBound(ListItem)
          ListItem(i) = .Paragraphs(i + 1).Range.Text 'заполняем массив текстом из выделения
        Next i
        If .Paragraphs.Count / 2 - .Paragraphs.Count \ 2  0 Then
          sOddOrEven = "Odd"
        Else: sOddOrEven = "Even": End If
        nParagCount = .Paragraphs.Count \ 2
        .Delete
        For i = 0 To nParagCount - 1
          .Text = ListItem(i)
          .Collapse wdCollapseEnd
          .Text = ListItem(nParagCount + i)
          .Collapse wdCollapseEnd
        Next i
        If sOddOrEven = "Odd" Then
          .TypeBackspace
          .MoveUp Unit:=wdLine, Count:=nParagCount
          .EndKey Unit:=wdLine
          .TypeParagraph
          .Text = ListItem(UBound(ListItem))
          .Collapse wdCollapseEnd
          .MoveDown wdLine
          .TypeBackspace
        Else: .TypeBackspace: End If
        .HomeKey wdStory, wdExtend
        .Range.ListFormat.ApplyNumberDefault
        .Collapse wdCollapseStart
      End With
    End Sub

  3. 14.01.2009 в 08:30 | #3

    Александр, спасибо за помощь.

  4. Галина
    14.01.2009 в 17:35 | #4

    Александр, спасибо большое, постоянно пользуюсь макросами Антона, - делаю экзаменационные билеты из вопросов, макеты учебников; и перемешивание оч кстати. Макросов нужных в моем Normal - уже не один десяток, как же это удобно! спасибо-спасибо-спасибо.

  5. 14.01.2009 в 18:49 | #5

    Попробовал. Список из 15 элементов вернулся в исходное состояние за 13 попыток. Вот код:

    Sub ReArrangeList()
      Dim ListItem(), ListItemTemplate() As String
      Dim i, nParagCount As Integer
      Dim nAttCounter As Long
      Dim sOddOrEven As String
      Dim bDone As Boolean
      bDone = True
      ReDim ListItemTemplate(Selection.Paragraphs.Count - 1)
      For i = 0 To UBound(ListItemTemplate)
        ListItemTemplate(i) = Selection.Paragraphs(i + 1).Range.Text 'заполняем массив текстом из выделения
      Next i
      Do
      nAttCounter = nAttCounter + 1
      With Selection
        ReDim ListItem(.Paragraphs.Count - 1) 'определяем размер массива
        For i = 0 To UBound(ListItem)
          ListItem(i) = .Paragraphs(i + 1).Range.Text 'заполняем массив текстом из выделения
        Next i
        If .Paragraphs.Count / 2 - .Paragraphs.Count \ 2  0 Then
          sOddOrEven = "Odd"
        Else: sOddOrEven = "Even": End If
        nParagCount = .Paragraphs.Count \ 2
        .Delete
        For i = 0 To nParagCount - 1
          .Text = ListItem(i)
          .Collapse wdCollapseEnd
          .Text = ListItem(nParagCount + i)
          .Collapse wdCollapseEnd
        Next i
        If sOddOrEven = "Odd" Then
          .TypeBackspace
          .MoveUp Unit:=wdLine, Count:=nParagCount
          .EndKey Unit:=wdLine
          .TypeParagraph
          .Text = ListItem(UBound(ListItem))
          .Collapse wdCollapseEnd
          .MoveDown wdLine
          .TypeBackspace
        Else: .TypeBackspace: End If
          .HomeKey wdStory
          .EndKey wdStory, wdExtend
          .Range.ListFormat.ApplyNumberDefault
    '      .Collapse wdCollapseStart
        For i = 0 To UBound(ListItem)
          ListItem(i) = .Paragraphs(i + 1).Range.Text 'заполняем массив текстом из выделения
        Next i
      End With
      For i = 0 To UBound(ListItem)
        If ListItem(i)  ListItemTemplate(i) Then bDone = False: Exit For Else bDone = True
      Next i
      Loop Until bDone
      MsgBox "Список вернулся в исходное состояние за " & nAttCounter & " попыток.", , "Закончено"
    End Sub

  6. Серёга
    15.01.2009 в 13:06 | #6

    Преобразовать текст в таблицу из одного столбца.

    Вторую половину таблицы перетащить выше для создания второго столбца.

    Преобразовать таблицу в текст с разделителм «Знак абзаца».

    Немного сложнее только выделить половину таблицы, если нет нумерации. Но можно временно её включить для выделенного текста, а после преобразования снять.

  7. 15.01.2009 в 16:53 | #7

    Это еще можно сделать, если нужно преобразовать один список. А когда таких документов 5, 10, 50? Эти действия Галина и делала, но это занимало массу времени и сил.

  8. Галина
    20.01.2009 в 19:44 | #8

    вопрос Александру.

    здравствуйте, создала новый модуль, скопировала макрос - комментарии с апострофом, зеленые, а вот эти две строки - красные:

    If .Paragraphs.Count / 2 - .Paragraphs.Count \ 2 0 Then
    If ListItem(i) ListItemTemplate(i) Then bDone = False: Exit For Else bDone = True

    не знаю, что в них надо исправить.

    помогите, пожалуйста.

  9. 20.01.2009 в 20:01 | #9

    после .Paragraphs.Count \ 2 в первой строке и после If ListItem(i) во второй строке должен стоять знак равно. Он почему-то теряется при вставке в сообщение.

    Кстати, этот макрос работает довольно не стабильно. Максимум у меня получилось вернуть в исходное состояние 80 пунктов за 387 попыток, а больше почему-то выдает ошибку среди процесса. Но для одного-двух раз перемещивания — подойдет.

  10. Галина
    21.01.2009 в 11:25 | #10

    спасибо.

  11. Виктор
    27.01.2009 в 08:57 | #11

    Здравствуйте,Антон!

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

  12. 27.01.2009 в 15:26 | #12

    Точки входа для задания вопроса нет, потому что очень много вопросов, и Антон один не справляется. Частые посетители форума помогают по мере возможности.

    По сути вопроса. Конечно. Пишите на viter.alex «собака» gmail точка com. Желательно с файлом примера исходного содержимого.

Оставьте комментарий!

(обязательно)

^ Наверх