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

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

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

Рубрика: Вопрос-Ответ, Макросы, Стили и форматирование
Метки: | | |
Вторник, 13 января 2009 г.
Просмотров: 2507
Подписаться на комментарии по RSS
Версия для печати

[Ссылки на статью]

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

Есть список вопросов. Для разных дисциплин разное количество - от 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 Вконтакте Google Buzz google.com bobrdobr.ru del.icio.us technorati.com linkstore.ru news2.ru rumarkz.ru memori.ru moemesto.ru]]>

Это может пригодиться:

Комментариев: 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. Желательно с файлом примера исходного содержимого.

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

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

контакты

 
^ Наверх