09-08-2016. Добавлена корректная сортировка чисел. Автор: МатросНаЗебре 15-09-2016. Минорные изменения для удобства (разные разделители для расцепки/сцепки) и понятные аргументы. Автор: Jack_Famous А также в посте #15 добавлен макрос от Sanja сортировки по месяцам (только для месяцев)
Код
'Сортировка данных внутри ячейки
'Авторы: GWolf и MCH
'Редактор (сортировка чисел): МатросНаЗебре
'Минорные изменения для удобства: Jack_Famous
'Сайт-источник: http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=72769&MID=609946#message609946
'Сайт-оригинал: http://forum.msexcel.ru/index.php?topic=7488.0
'Аргументы функции:
'Ячейка - ячейка-источник
'РазделительСловосочетаний - необязательный аргумент. Разделитель, по которому определяются границы слов/фраз, которые впоследствии будут отсортированы (по умолчанию - пробел). Указать "10", в качестве переноса строки
'ОбъединитьЧерез - необязательный аргумент. Разделитель, через который сцепляются расцепленные и отсортированные слова/фразы (по умолчанию - пробел). Указать "10", в качестве переноса строки
'==========================================================================================================================================================================================================================
Function СортироватьВнутриЯчейки(Ячейка As Range, Optional РазделительСловосочетаний As String = " ", Optional ОбъединитьЧерез As String = " ") As String
Dim Arr
If РазделительСловосочетаний = "10" Then РазделительСловосочетаний = Chr(10)
If ОбъединитьЧерез = "10" Then ОбъединитьЧерез = Chr(10)
Arr = Split(Ячейка, РазделительСловосочетаний)
СортироватьВнутриЯчейки = Join(SortArr(Arr), ОбъединитьЧерез)
End Function
Function SortArr(ByVal Arr)
Dim i&, j&, N&, tmp$
If Not IsArray(Arr) Then SortArr = Arr: Exit Function
N = UBound(Arr)
For i = 0 To N - 1
For j = i + 1 To N
If IsNumeric(Arr(i)) And IsNumeric(Arr(j)) Then
If Val(Arr(i)) > Val(Arr(j)) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp
Else
If Arr(i) > Arr(j) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp
End If
Next j, i
SortArr = Arr
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
макрос не плохой, Решил воспользоваться им в новом файле с расширением .xlsm и excel у меня завис. Работает макрос только в версии 97-2003. Т.е. он работает и в новой версии excel, но при перезапуске книги, зависает.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Доброго вечера, планетяне! Помогите пожалуйста с одним нюансом сортировки… UDF без проблем сортирует текст (по правилам Excel), а вот при сортировке чисел (когда в ячейке только числа и разделители) сортирует не по правилам. Как нужно изменить существующую UDF, чтобы она корректно сортировала числа? Или, может, нужно отдельную UDF для сортировки чисел писать?… Уровень VBA: иногда могу немного скорректировать чужой код )))) Помогите пожалуйста…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Добрый день! подниму тему, а как можно отсортировать внутри ячеек по месяцам, например в ячейке перечислены месяца не по порядку. а нужно что бы были по порядку....
Татьяна, по-хорошему - исправлять макрос (добавить список по месяцам). Если по-простому, то заменить (массовая замена) все названия месяцев, добавить к названию индекс по порядку: 01январь, 02февраль и т.д. - в таком случае макрос сработает. Потом можно поменять обратно
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Татьяна, всегда пожалуйста я тоже не силён в макросах))))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Вариант только для месяцев. Названия месяцев не должны повторяться. Точнее повторяться могут, но будет учитываться только первый из повторов
Код
Option Compare Text
Function ПОМЕСЯЦАМ(cl As Range, Optional dl As String = ",") As String
arrMonths = Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
ReDim tmpArr(UBound(arrMonths))
For I = LBound(arrMonths) To UBound(arrMonths)
For J = 0 To UBound(Split(Trim(cl), dl))
s = Trim(Split(Trim(cl), dl)(J))
If s = arrMonths(I) Then tmpArr(I) = s
Next
Next
For I = LBound(tmpArr) To UBound(tmpArr)
If tmpArr(I) <> Empty Then
If ПОМЕСЯЦАМ = Empty Then
ПОМЕСЯЦАМ = tmpArr(I)
Else
ПОМЕСЯЦАМ = ПОМЕСЯЦАМ & dl & " " & tmpArr(I)
End If
End If
Next
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Без ограничений на количество наименований одного месяца
Скрытый текст
Код
Function ПОМЕСЯЦАМ(cl As Range, Optional dl As String = ",") As String
Dim dicMonths
arrMonths = Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
Set dicMonths = CreateObject("Scripting.Dictionary")
On Error Resume Next
For I = 0 To UBound(Split(Trim(cl), dl))
d = 1
s = WorksheetFunction.Match(Trim(Split(Trim(cl), dl)(I)), arrMonths, 0)
dicMonths.Add CLng(DateSerial(2000, s, d)), CStr(I)
Do While Err <> 0
d = d + 1
Err.Clear
dicMonths.Add CLng(DateSerial(2000, s, d)), CStr(I)
Loop
Next
For I = 1 To dicMonths.Count
If ПОМЕСЯЦАМ = Empty Then
ПОМЕСЯЦАМ = MonthName(Month(CDate(WorksheetFunction.Small(dicMonths.Keys, I))))
Else
ПОМЕСЯЦАМ = ПОМЕСЯЦАМ & dl & MonthName(Month(CDate(WorksheetFunction.Small(dicMonths.Keys, I))))
End If
Next
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Здравствуйте. Что то не могу разобраться с сортировкой данных внутри ячеек. Надо внутри ячеек отсортировать данные примерно такого вида: NZE121, NZE124, NZE120, CE121, ZZE123, ZZE123, ZZE124 и затем удалить дублирующиеся. или хотя бы одну из функций. Если конечно возможно такое. Я то что то на форуме только имена и числа. пробую поменять под свои требования, вечно ругается что что то не то.
Sub SortUniq()
Dim Arr, i As Long, k As Long, s As String, x As Long
Arr = Split(Range("A1"), ", ")
On Error Resume Next
With New Collection
For x = 0 To UBound(Arr)
s = Trim(Arr(x))
If Len(s) > 0 Then
If IsEmpty(.Item(s)) Then
For i = 1 To .Count
If s < .Item(i) Then Exit For
Next
If i > .Count Then .Add s, s Else .Add s, s, Before:=i
End If
End If
Next
ReDim Arr(1 To .Count)
For i = 1 To .Count
Arr(i) = .Item(i)
Next
End With
Range("A2").Resize(1, i - 1).Value = Arr
End Sub
Если это маркос для сортировки, то он не работает. Но есть плюсы, не ругается. И вопрос не в том: сделайте., а в том как надо делать. Пробовал и столбец А, Может он конечно для какой то специальной строки #17. Тогда как это переделать для любых строк.
2.3. Приложите файл(ы) с примером (общим весом не более 100 Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.
Если я правильно понял, то требуется выбрать уникальные значения и отсортировать их внутри ячейки с данными. Если так, то выделите ячейку (диапазон ячеек) с данными и выполните макрос:
Код
Sub SortOnPlace()
Dim i As Long, j As Long, r As Range, x, y, z, a()
Set x = CreateObject("Scripting.Dictionary")
Selection.Replace ",", ", " 'на случай, если нет пробела после запятой
For Each r In Selection
y = Split(Application.Trim(r), ", ")
For Each z In y: x.Item(z) = z: Next
a = x.Items
For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If a(i) > a(j) Then
z = a(i): a(i) = a(j): a(j) = z
End If
Next
Next
r = Join(a, ", "): x.RemoveAll
Next
End Sub
JAPANCARTS написал: Если это маркос для сортировки, то он не работает
Работает. И не только сортирует, но и удаляет дубликаты.
Цитата
JAPANCARTS написал: Может он конечно для какой то специальной строки #17
Это "специальная" строка та, которую Вы для примера указали в своём сообщении №17 - NZE121, NZE124, NZE120, CE121, ZZE123, ZZE123, ZZE124. Напишите в ячейку А1 этот текст и выполните макрос - в ячейке А2 получите отсортированный результат и без дубликатов.
Цитата
JAPANCARTS написал: И вопрос не в том: сделайте., а в том как надо делать
Т.е. Вам нужно было не решение, а ОПИСАНИЕ, как делать? Как сделать - я Вам показал. Если нужно перебрать несколько ячеек - добавьте цикл перебора этих ячеек.Если нужно результат выводить в другие ячейки - измените адрес выгрузки. И согласен с JayBhagavan - Ваше утверждение голословно.
Прикрепил пример. Проблем с числами нет, сортировка работает, но не работает с размерами вида XS - S - M и т.д. Все размеры в одном файле. Нет ли общего решения для сортировки чисел и букв?
Казанский, это прайс лист. Одежда и обувь. Разные размеры, числовые такие как 40,42,44, еще такие 40-42,42-44,44-46, с ними проблем не возникло. Еще есть размеры XXS,XS,S и т.д. С ними пока делаю, как Jack Famous написал по простому, путем переименования 01XXS, 02XS и т.д. А связано это с тем, что это все находится внутри ячеек у каждого товара свои размеры. И они изначально подтягиваются мне почему то в хаотичном порядке. Т.е. у товара размеры 2XL, S,M,XXS, а нужен порядок внутри ячейки XXS,XS,S,M,L,XL,2XL, а также 40,42 и 40-42,42-44 и т.д.