Статьи из блога
Разбиение списка на части
Галина задала вопрос:
Есть список вопросов. Для разных дисциплин разное количество - от 30 до 60-ти. Их надо разделить пополам и соединить потом через один, то есть, при 60-ти вопросах нужно их объединить так: 1й и 31й, 2й и 32й... 30й и 60й. Просто вырезать и вставлять или копировать и вставлять - путаница, смещается нумерация, забываешь, какие вставила, какие нет. Можно как-то решить эту проблему?
Можно воспользоваться следующим макросом для разбиения списка на две части. Он нормально работает и с круглыми цифрами (50, 60) и четными некруглыми (52, 64). Для нечетных он оставляет в самом конце один повторный номер/вопрос.
Выделите ваш список и примените макрос:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | 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 |
Для разбиения списка на три части используйте следующий макрос:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | 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 |
Рубрика: Вопрос-Ответ, Макросы, Стили и форматирование
Метки: макросы | нумерация | списки | форматирование
Просмотров: 14935
Подписаться на комментарии по RSS
Версия для печати
Метки: макросы | нумерация | списки | форматирование
Просмотров: 14935
Подписаться на комментарии по 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? Эти действия Галина и делала, но это занимало массу времени и сил.
вопрос Александру.
здравствуйте, создала новый модуль, скопировала макрос - комментарии с апострофом, зеленые, а вот эти две строки - красные:
If
.Paragraphs.Count / 2 - .Paragraphs.Count \ 2 0
Then
If
ListItem(i) ListItemTemplate(i)
Then
bDone =
False
:
Exit
For
Else
bDone =
True
не знаю, что в них надо исправить.
помогите, пожалуйста.
после .Paragraphs.Count \ 2 в первой строке и после If ListItem(i) во второй строке должен стоять знак равно. Он почему-то теряется при вставке в сообщение.
Кстати, этот макрос работает довольно не стабильно. Максимум у меня получилось вернуть в исходное состояние 80 пунктов за 387 попыток, а больше почему-то выдает ошибку среди процесса. Но для одного-двух раз перемещивания — подойдет.
спасибо.
Здравствуйте,Антон!
Извините, не нашел на Вашем сайте точки входа для задания нового вопроса, поэтому приклеился к обсуждению имеющегося. Вопрос такой: в документе Word есть растровый рисунок и текст, обрамленные для ясности разделителями, например, знаком "#". Нет ли возможности эти элементы как-то вычленить и выложить раздельно на форму VBA или VB?
Точки входа для задания вопроса нет, потому что очень много вопросов, и Антон один не справляется. Частые посетители форума помогают по мере возможности.
По сути вопроса. Конечно. Пишите на viter.alex «собака» gmail точка com. Желательно с файлом примера исходного содержимого.