Статьи из блога
Разбиение списка на части
Галина задала вопрос:
Есть список вопросов. Для разных дисциплин разное количество - от 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
Рубрика: Вопрос-Ответ, Макросы, Стили и форматирование
Метки: макросы | нумерация | списки | форматирование
Просмотров: 14595
Подписаться на комментарии по RSS
Версия для печати
Метки: макросы | нумерация | списки | форматирование
Просмотров: 14595
Подписаться на комментарии по RSS
Версия для печати
Еще записи по вопросам использования Microsoft Word:
- 10 вопросов и ответов по редактору Word (1 часть)
- 3 способа очистки списка недавно открытых документов
- Word 2007: добавляем свою вкладку и свои команды
- Word 2007: полотно, рисунки, линии
- Word 2007: смена формата сохранения файла
- Word 97 - решение проблемы с отображением символов на линейке
- Word 97. Слияние документов как один из способов упростить свою работу
- Абзац с цветным фоном
- Автозаполняемые колонтитулы
- Автоматизация текстового набора в Word
- Автоматическая запись макроса
- Автоматическая нумерация билетов
- Автоматическая расстановка переносов
- Автоматическое обновление полей при открытии документа
- Автоматическое сохранение документа при его закрытии
- Автотекст с последовательной нумерацией
- Автоформат документов
- Белый текст на синем фоне в Word 2007
- Буквица
- Быстрая смена ориентации страниц документа
- Быстрое изменение стиля форматирования текста
- Быстрое перемещение между открытыми документами Word
- Быстрое создание нового документа на основе шаблона
- Быстрое удаление границ у таблицы
- Быстрый ввод текста с помощью команды =rand()
Форум
Читают
Обсуждают
страницы
сайты
статистика
Комментариев: 12
Антон, как всегда блестяще. Нет слов. Только жаль, что список теряется.
Думаю Галине будет интересен такой вариант макроса для сортировки. Список не теряется. Сортирует как четное так и нечетное количество пунктов. После нескольких сортировок, примененных к одному и тому же списку, он очень хорошо перемешивается. Интересно, а в исходное состояние восстановится? Надо подумать. И за сколько сортировок?
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Александр, спасибо за помощь.
Александр, спасибо большое, постоянно пользуюсь макросами Антона, - делаю экзаменационные билеты из вопросов, макеты учебников; и перемешивание оч кстати. Макросов нужных в моем Normal - уже не один десяток, как же это удобно! спасибо-спасибо-спасибо.
Попробовал. Список из 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Преобразовать текст в таблицу из одного столбца.
Вторую половину таблицы перетащить выше для создания второго столбца.
Преобразовать таблицу в текст с разделителм «Знак абзаца».
Немного сложнее только выделить половину таблицы, если нет нумерации. Но можно временно её включить для выделенного текста, а после преобразования снять.
Это еще можно сделать, если нужно преобразовать один список. А когда таких документов 5, 10, 50? Эти действия Галина и делала, но это занимало массу времени и сил.
вопрос Александру.
здравствуйте, создала новый модуль, скопировала макрос - комментарии с апострофом, зеленые, а вот эти две строки - красные:
не знаю, что в них надо исправить.
помогите, пожалуйста.
после .Paragraphs.Count \ 2 в первой строке и после If ListItem(i) во второй строке должен стоять знак равно. Он почему-то теряется при вставке в сообщение.
Кстати, этот макрос работает довольно не стабильно. Максимум у меня получилось вернуть в исходное состояние 80 пунктов за 387 попыток, а больше почему-то выдает ошибку среди процесса. Но для одного-двух раз перемещивания — подойдет.
спасибо.
Здравствуйте,Антон!
Извините, не нашел на Вашем сайте точки входа для задания нового вопроса, поэтому приклеился к обсуждению имеющегося. Вопрос такой: в документе Word есть растровый рисунок и текст, обрамленные для ясности разделителями, например, знаком "#". Нет ли возможности эти элементы как-то вычленить и выложить раздельно на форму VBA или VB?
Точки входа для задания вопроса нет, потому что очень много вопросов, и Антон один не справляется. Частые посетители форума помогают по мере возможности.
По сути вопроса. Конечно. Пишите на viter.alex «собака» gmail точка com. Желательно с файлом примера исходного содержимого.