Добрый день! Дана таблица из нескольких столбцов с заголовками. Заголовки - это категории, остальные значения в столбцах - номера товаров. Нужно номера поместить в один столбец, а во второй столбец добавить соответствующие номерам категории. Пример во вложении. Посмотрите, пожалуйста. Заранее спасибо!
Добрый день! Дана таблица из нескольких столбцов с заголовками. Заголовки - это категории, остальные значения в столбцах - номера товаров. Нужно номера поместить в один столбец, а во второй столбец добавить соответствующие номерам категории. Пример во вложении. Посмотрите, пожалуйста. Заранее спасибо!saari
Вариант макросом. В файле макроса нет. Файл я выложил, чтобы показать, с каким листом работает макрос.
[vba]
Код
Sub Создать_список()
Dim arrSrc(), arrRes() Dim lr As Long, lc As Long, r As Long, i As Long, j As Long
lr = Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _ , SearchFormat:=False).Row lc = Cells(1, Columns.Count).End(xlToLeft).Column arrSrc() = Range("A1").Resize(lr, lc).Value ReDim arrRes(1 To lr * lc, 1 To 2)
For j = 1 To UBound(arrSrc, 2) For i = 2 To UBound(arrSrc, 1) If arrSrc(i, j) <> "" Then r = r + 1 arrRes(r, 1) = arrSrc(i, j) arrRes(r, 2) = arrSrc(1, j) End If Next i Next j
Вариант макросом. В файле макроса нет. Файл я выложил, чтобы показать, с каким листом работает макрос.
[vba]
Код
Sub Создать_список()
Dim arrSrc(), arrRes() Dim lr As Long, lc As Long, r As Long, i As Long, j As Long
lr = Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _ , SearchFormat:=False).Row lc = Cells(1, Columns.Count).End(xlToLeft).Column arrSrc() = Range("A1").Resize(lr, lc).Value ReDim arrRes(1 To lr * lc, 1 To 2)
For j = 1 To UBound(arrSrc, 2) For i = 2 To UBound(arrSrc, 1) If arrSrc(i, j) <> "" Then r = r + 1 arrRes(r, 1) = arrSrc(i, j) arrRes(r, 2) = arrSrc(1, j) End If Next i Next j
Ну и до кучи вариант пользовательской функции [vba]
Код
Function saari(category As Range, tovar As Range, q As Boolean, i As Integer) arr1 = category.Value arr2 = Application.Transpose(tovar.Value) If i < LBound(arr2) Or i > WorksheetFunction.Count(tovar) Then Exit Function x = 1 y = 1 With CreateObject("Scripting.Dictionary") Do While .Count < i If Not IsEmpty(arr2(y, x)) Then .Add Key:=arr2(y, x), Item:=arr1(1, y) x = IIf(x = UBound(arr2, 2), 1, x + 1) y = IIf(x = 1, y + 1, y) Loop If q Then iarr = .items saari = iarr(i - 1) Else karr = .keys saari = karr(i - 1) End If End With End Function
[/vba]
Ну и до кучи вариант пользовательской функции [vba]
Код
Function saari(category As Range, tovar As Range, q As Boolean, i As Integer) arr1 = category.Value arr2 = Application.Transpose(tovar.Value) If i < LBound(arr2) Or i > WorksheetFunction.Count(tovar) Then Exit Function x = 1 y = 1 With CreateObject("Scripting.Dictionary") Do While .Count < i If Not IsEmpty(arr2(y, x)) Then .Add Key:=arr2(y, x), Item:=arr1(1, y) x = IIf(x = UBound(arr2, 2), 1, x + 1) y = IIf(x = 1, y + 1, y) Loop If q Then iarr = .items saari = iarr(i - 1) Else karr = .keys saari = karr(i - 1) End If End With End Function
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
вариант пользовательской функции
