Всем, добрый вечер. Пытаюсь написать макрос, но не хватает знаний( Суть макроса в следующем: на первом листе в колону А вписываются продукты, справа от продукта в строчку указываются возможные коды этого продукта. Макрос подтягивает все возможные комбинации Код+Продукт в таблицу на листе 2, также на лист 2 проставляет в колонку А слово все. Пример приложил. Буду благодарен за помощь:)
Всем, добрый вечер. Пытаюсь написать макрос, но не хватает знаний( Суть макроса в следующем: на первом листе в колону А вписываются продукты, справа от продукта в строчку указываются возможные коды этого продукта. Макрос подтягивает все возможные комбинации Код+Продукт в таблицу на листе 2, также на лист 2 проставляет в колонку А слово все. Пример приложил. Буду благодарен за помощь:)Олег78
Sub ertert() Dim x, y(), i&, j&, k& x = Sheets("Sheet1").Range("A1").CurrentRegion.Value ReDim y(1 To UBound(x) * UBound(x, 2), 1 To 3) For i = 1 To UBound(x) For j = 2 To UBound(x, 2) If Len(x(i, j)) Then k = k + 1: y(k, 1) = "All": y(k, 2) = x(i, j): y(k, 3) = x(i, 1) Next j Next i With Sheets("Sheet2") .UsedRange.ClearContents .Range("A1:C1").Value = Array("Type", "Code", "Name") .Range("A2:C2").Resize(k).Value = y() .Activate End With End Sub
[/vba]
Привет, Олег попробуйте так: [vba]
Код
Sub ertert() Dim x, y(), i&, j&, k& x = Sheets("Sheet1").Range("A1").CurrentRegion.Value ReDim y(1 To UBound(x) * UBound(x, 2), 1 To 3) For i = 1 To UBound(x) For j = 2 To UBound(x, 2) If Len(x(i, j)) Then k = k + 1: y(k, 1) = "All": y(k, 2) = x(i, j): y(k, 3) = x(i, 1) Next j Next i With Sheets("Sheet2") .UsedRange.ClearContents .Range("A1:C1").Value = Array("Type", "Code", "Name") .Range("A2:C2").Resize(k).Value = y() .Activate End With End Sub
Вариант, в модуль листа 1(без очистки листа 2): [vba]
Код
Public Sub www() Dim a, i&, j&, d&, n& d = [a1].CurrentRegion.SpecialCells(2, 1).Count a = [a1].CurrentRegion ReDim b(1 To d, 1 To 3) For i = 1 To UBound(a) For j = 2 To UBound(a, 2) If a(i, j) <> "" Then n = n + 1 b(n, 1) = "Все": b(n, 3) = a(i, 1) b(n, 2) = a(i, j) End If Next Next Sheets("Sheet2").[a2].Resize(d, 3) = b End Sub
[/vba]
Вариант, в модуль листа 1(без очистки листа 2): [vba]
Код
Public Sub www() Dim a, i&, j&, d&, n& d = [a1].CurrentRegion.SpecialCells(2, 1).Count a = [a1].CurrentRegion ReDim b(1 To d, 1 To 3) For i = 1 To UBound(a) For j = 2 To UBound(a, 2) If a(i, j) <> "" Then n = n + 1 b(n, 1) = "Все": b(n, 3) = a(i, 1) b(n, 2) = a(i, j) End If Next Next Sheets("Sheet2").[a2].Resize(d, 3) = b End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
