Приветствую вас, уважаемые гуру! Прошу вашей помощи в решении непростой, но важной задачи. Есть файл с разными параметрами товаров, которые перечисляются в строке по отдельным ячейкам. Нужно переставить ячейки в строке так, чтобы в одной колонке собрались все, которые начинаются одинаково (условием будет текст до символа ":"). И желательно в заголовок колонки этот текст и поместить. Полагаю, что формулы здесь бессильны. А возможно ли это сделать посредством макроса? Прикрепляю файлики для наглядности.
Потрудитесь привести пример в порядок и заменить то, что есть, нормальным. Для удобства помогающих лучше сделать два листа в одной книге, подразумевая, что это две разных книги.
Sanja, теоретически это одно и то же, но все-таки лучше разносить отдельно, т.к. могут встретиться варианты написания типа "длина спинки" или что-то еще, а это уже разные понятия.... vikttur, пример поправила
Обычная сортировка каждого столбца отдельно, не подходит? В столбах появились пустые ячейки, от куда? Поясните подробнее, что от куда и почему. Можно показать в одном файле по три столбца на разных листах, так было-так должно получиться.
Эх, всегда у меня с объяснением пробуксовка.. (( gling, при сортировке внутри столбца происходит изменение порядка ячеек. А они не должны менять свое расположение относительно строчки, т.к. это параметры одного товара. Выкладываю исходный файл целиком и результат в полном виде:
Последний пример не видел, проверьте на нем сами. Вариант в файле. Результат выводится на лист РЕЗУЛЬТАТ
Скрытый текст
Код
Sub SeatOptions()
Dim arr(), arrNew(), I&, J&, N&, iKey
With Worksheets("Как есть").UsedRange
Trim (.Replace("::", ":"))
arr = .Value
End With
On Error Resume Next
With CreateObject("Scripting.Dictionary")
For J = 1 To UBound(arr, 2)
For I = 1 To UBound(arr)
ReDim iArr(0)
iKey = Trim(Split(arr(I, J), ":")(0)): iArr(0) = Trim(arr(I, J))
.Add iKey, iArr
If Err <> 0 Then
iArr = .Item(iKey)
ReDim Preserve iArr(UBound(iArr) + 1)
iArr(UBound(iArr)) = Trim(arr(I, J))
.Item(iKey) = iArr
Err.Clear
End If
Next
Next
ReDim arrNew(0 To UBound(arr) * UBound(arr, 2), 1 To UBound(.Keys)): N = 1
For Each iKey In .Keys
arrNew(0, N) = iKey
iArr = .Item(iKey)
For J = 0 To UBound(iArr)
arrNew(J + 1, N) = iArr(J)
Next
N = N + 1
Next
End With
With Worksheets("РЕЗУЛЬТАТ")
.Range("A1").Resize(UBound(arrNew) + 1, UBound(arrNew, 2)) = arrNew
.Rows(1).Font.Bold = True
End With
End Sub
Объясню логику процесса, как я это вижу: 1. макрос смотрит первый столбец 2. проверяет первую непустую ячейку, берет из нее заголовок (текст до символа ":"), ставит в шапку 3. спускается на следующую строчку вниз, выполняет условие: а) если начало строки совпадает с заголовком, то ячейка остается на месте б) если начало строки НЕ совпадает, то вставляется пустая ячейка со сдвигом вправо. 4. повторяет условие до конца таблицы и переходит к следующему столбцу.