Сломал мозг, пытаясь решить одну практическую задачу. Хочу создать электронный журнал с результатами тестирования определенных материалов (см. приложение).
Собственно сам тип материала определяется в дропдаун списке в ячейке C(x). Согласно выбраному типу материала (например "Известь") произвести поиск в диапазоне ($H$3:$I$17). После нахождения скопировать диапазон начиная со строки 4 колонки * и до строки COUNTA($*:$*)-1 в колонку D начиная со строки (х).
Решение желательно найти стандартными функциями Excel, без использования VBA.
Здравствуйте ув.Гуру!
Сломал мозг, пытаясь решить одну практическую задачу. Хочу создать электронный журнал с результатами тестирования определенных материалов (см. приложение).
Собственно сам тип материала определяется в дропдаун списке в ячейке C(x). Согласно выбраному типу материала (например "Известь") произвести поиск в диапазоне ($H$3:$I$17). После нахождения скопировать диапазон начиная со строки 4 колонки * и до строки COUNTA($*:$*)-1 в колонку D начиная со строки (х).
Решение желательно найти стандартными функциями Excel, без использования VBA.Neniu
Ну вот где-то так получилось. Формулу не оптимизировал. Формула=ИНДЕКС($H$3:$I$22;СТРОКА()-ПОИСКПОЗ(ПРОСМОТР(;-КОДСИМВ(C$3:C3);C$3:C3);C$3:C3;);ПОИСКПОЗ(ПРОСМОТР(;-КОДСИМВ(C$3:C3);C$3:C3);$H$3:$I$3;))
Обалдеть!
формулу оптимизирую сам. Спасибо огромное!
Цитата (_Boroda_)
Ну вот где-то так получилось. Формулу не оптимизировал. Формула=ИНДЕКС($H$3:$I$22;СТРОКА()-ПОИСКПОЗ(ПРОСМОТР(;-КОДСИМВ(C$3:C3);C$3:C3);C$3:C3;);ПОИСКПОЗ(ПРОСМОТР(;-КОДСИМВ(C$3:C3);C$3:C3);$H$3:$I$3;))
А как на счет макроса? Работа макросов должна быть разрешена в настройках безопасности Excel Попробуйте выбрать материал в выпадающем списке. См. файл.
А как на счет макроса? Работа макросов должна быть разрешена в настройках безопасности Excel Попробуйте выбрать материал в выпадающем списке. См. файл.AlexM
Как работает макрос в файле zurnals_new.xls Задействовано 3 модуля: Эта книга, Модуль Лист1 и Модуль1 Код в модуле Эта книга [vba]
Код
Private Sub Workbook_Open() Range("A1").Select End Sub
[/vba] Делает активной ячейку А1, тут не принципиально какую, лишь бы не в столбце С. Нужно для правильной обработки события SelectionChange Код модуле Лист1 (второй) [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Range("C2:C1000"), Target) Is Nothing Then 'Если выбрана ячейка из указанного диапазона ИСТИНА For i = 3 To Sheets("Sheet2").Cells(3, 3).End(xlToRight).Column ' Цикл по названиям материалов, чтобы определить номер столбца. If Sheets("Sheet2").Cells(3, i) = Target.Value Then NameMaterial = i 'Taget - объект, Target.Value - значение. Если нашли материал, то записываем номер столбца в переменную NameMaterial* Next i End If End Sub
[/vba] * Переменная NameMaterial объявлена в Модуле1[vba]
Код
Public NameMaterial As Long
[/vba] При наступлении события SelectionChange, при выборе ячеек в столбце С запоминается материал (OLD), который был до изменения значения в выпадающем списке. Код модуле Лист1 (первый) [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("C2:C1000"), Target) Is Nothing Then 'Если выбрана ячейка из указанного диапазона ИСТИНА Application.EnableEvents = False 'отключаем события на время работы макроса For i = 3 To Sheets("Sheet2").Cells(3, 3).End(xlToRight).Column ' Цикл по названиям материалов, чтобы определить номер столбца. If Sheets("Sheet2").Cells(3, i) = Target.Value Then Exit For ' тут значение объекта Target, которое выбрано в выпадающем списке Next i CRowN = Sheets("Sheet2").Cells(3, i).End(xlDown).Row - 3 'Количество элементов в N(New) выбраном материале CRowO = Sheets("Sheet2").Cells(3, NameMaterial).End(xlDown).Row - 3 'Количество элементов в O(Old) в материале, до выбора новового If Target.Offset(0, 1) <> "" And Target.Offset(0, 1) <> "-" Then 'Target.Offset(0, 1) - ячейка правее той, в которой были изменения Rows(Target.Row + 1 & ":" & Target.Row + CRowO - 1).Delete Shift:=xlUp 'Удаляются строки со старыми элементами Target.Offset(0, 1) = "" End If If CRowN > 1 Then Rows(Target.Row + 1).Resize(CRowN - 1).EntireRow.Insert 'Вставляются строки по количеству новых элементов Sheets("Sheet2").Range(Sheets("Sheet2").Cells(4, i), Sheets("Sheet2").Cells(4 + CRowN - 1, i)).Copy (Sheets("Sheet1").Cells(Target.Row, 4)) 'копируется список элементов Target.Offset(0, 1).Select 'перемещение с ячеек столбца С. Нужно для правильной обработки события SelectionChange Application.EnableEvents = True 'Включение событий End If End Sub
[/vba]
Некоторые переменные остались не объявлены т.е. Variant Правильно было бы объявить [vba]
Код
Dim i as Long, CRowN as Long, CRowO as Long
[/vba] Объявить их надо в первом коде Лист1
Кажется все описал.
Как работает макрос в файле zurnals_new.xls Задействовано 3 модуля: Эта книга, Модуль Лист1 и Модуль1 Код в модуле Эта книга [vba]
Код
Private Sub Workbook_Open() Range("A1").Select End Sub
[/vba] Делает активной ячейку А1, тут не принципиально какую, лишь бы не в столбце С. Нужно для правильной обработки события SelectionChange Код модуле Лист1 (второй) [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Range("C2:C1000"), Target) Is Nothing Then 'Если выбрана ячейка из указанного диапазона ИСТИНА For i = 3 To Sheets("Sheet2").Cells(3, 3).End(xlToRight).Column ' Цикл по названиям материалов, чтобы определить номер столбца. If Sheets("Sheet2").Cells(3, i) = Target.Value Then NameMaterial = i 'Taget - объект, Target.Value - значение. Если нашли материал, то записываем номер столбца в переменную NameMaterial* Next i End If End Sub
[/vba] * Переменная NameMaterial объявлена в Модуле1[vba]
Код
Public NameMaterial As Long
[/vba] При наступлении события SelectionChange, при выборе ячеек в столбце С запоминается материал (OLD), который был до изменения значения в выпадающем списке. Код модуле Лист1 (первый) [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("C2:C1000"), Target) Is Nothing Then 'Если выбрана ячейка из указанного диапазона ИСТИНА Application.EnableEvents = False 'отключаем события на время работы макроса For i = 3 To Sheets("Sheet2").Cells(3, 3).End(xlToRight).Column ' Цикл по названиям материалов, чтобы определить номер столбца. If Sheets("Sheet2").Cells(3, i) = Target.Value Then Exit For ' тут значение объекта Target, которое выбрано в выпадающем списке Next i CRowN = Sheets("Sheet2").Cells(3, i).End(xlDown).Row - 3 'Количество элементов в N(New) выбраном материале CRowO = Sheets("Sheet2").Cells(3, NameMaterial).End(xlDown).Row - 3 'Количество элементов в O(Old) в материале, до выбора новового If Target.Offset(0, 1) <> "" And Target.Offset(0, 1) <> "-" Then 'Target.Offset(0, 1) - ячейка правее той, в которой были изменения Rows(Target.Row + 1 & ":" & Target.Row + CRowO - 1).Delete Shift:=xlUp 'Удаляются строки со старыми элементами Target.Offset(0, 1) = "" End If If CRowN > 1 Then Rows(Target.Row + 1).Resize(CRowN - 1).EntireRow.Insert 'Вставляются строки по количеству новых элементов Sheets("Sheet2").Range(Sheets("Sheet2").Cells(4, i), Sheets("Sheet2").Cells(4 + CRowN - 1, i)).Copy (Sheets("Sheet1").Cells(Target.Row, 4)) 'копируется список элементов Target.Offset(0, 1).Select 'перемещение с ячеек столбца С. Нужно для правильной обработки события SelectionChange Application.EnableEvents = True 'Включение событий End If End Sub
[/vba]
Некоторые переменные остались не объявлены т.е. Variant Правильно было бы объявить [vba]
Для доведения в рабочее состояние скрипта, пришлось сделать следующие изменения:
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) NameMaterial = 1 If Not Intersect(Range("C2:C1000"), Target) Is Nothing And Selection.Cells.Count = 1 Then For i = 3 To Sheets("Sheet2").Cells(3, 3).End(xlToRight).Column If Sheets("Sheet2").Cells(3, i) = Target.Value Then NameMaterial = i Next i End If End Sub
[/vba]
Переменной пришлось присвоить начальное значение, ибо если этого не сделать, строчка [vba]
[/vba] вываливается с ошибкой. Обычно при нажатии Delete в пустой ячейке в колонке С.
[vba]
Код
Selection.Cells.Count = 1
[/vba] эту строчку пришлось добавить, чтобы макрос не выпадал с ошибкой, когда выделяются несколько ячеек.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("C2:C1000"), Target) Is Nothing Then Application.EnableEvents = False For i = 3 To Sheets("Sheet2").Cells(3, 3).End(xlToRight).Column If Sheets("Sheet2").Cells(3, i) = Target.Value Then Exit For Next i CRowN = Sheets("Sheet2").Cells(3, i).End(xlDown).Row - 3 CRowO = Sheets("Sheet2").Cells(3, NameMaterial).End(xlDown).Row - 3 If Target.Offset(0, 1) <> "" And Target.Offset(0, 1) <> "-" Then Rows(Target.Row + 1 & ":" & Target.Row + CRowO - 1).Delete Shift:=xlUp Target.Offset(0, 1) = "" End If If Target.Value = "" Then CRowN = 0 If CRowN > 1 Then Rows(Target.Row + 1).Resize(CRowN - 1).EntireRow.Insert Sheets("Sheet2").Range(Sheets("Sheet2").Cells(4, i), Sheets("Sheet2").Cells(4 + CRowN - 1, i)).Copy (Sheets("Sheet1").Cells(Target.Row, 4)) Target.Offset(0, 1).Select Application.EnableEvents = True End If End Sub
[/vba]
Пришлось добавить строчку If Target.Value = "" Then CRowN = 0, ибо при удалении выбранного ранее значения в колонке С, макрос исправно удалял строки по количеству материала, а новые не находил и выпадал с ошибкой.
Макрос работает отлично, спасибо AlexM!
Для доведения в рабочее состояние скрипта, пришлось сделать следующие изменения:
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) NameMaterial = 1 If Not Intersect(Range("C2:C1000"), Target) Is Nothing And Selection.Cells.Count = 1 Then For i = 3 To Sheets("Sheet2").Cells(3, 3).End(xlToRight).Column If Sheets("Sheet2").Cells(3, i) = Target.Value Then NameMaterial = i Next i End If End Sub
[/vba]
Переменной пришлось присвоить начальное значение, ибо если этого не сделать, строчка [vba]
[/vba] вываливается с ошибкой. Обычно при нажатии Delete в пустой ячейке в колонке С.
[vba]
Код
Selection.Cells.Count = 1
[/vba] эту строчку пришлось добавить, чтобы макрос не выпадал с ошибкой, когда выделяются несколько ячеек.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("C2:C1000"), Target) Is Nothing Then Application.EnableEvents = False For i = 3 To Sheets("Sheet2").Cells(3, 3).End(xlToRight).Column If Sheets("Sheet2").Cells(3, i) = Target.Value Then Exit For Next i CRowN = Sheets("Sheet2").Cells(3, i).End(xlDown).Row - 3 CRowO = Sheets("Sheet2").Cells(3, NameMaterial).End(xlDown).Row - 3 If Target.Offset(0, 1) <> "" And Target.Offset(0, 1) <> "-" Then Rows(Target.Row + 1 & ":" & Target.Row + CRowO - 1).Delete Shift:=xlUp Target.Offset(0, 1) = "" End If If Target.Value = "" Then CRowN = 0 If CRowN > 1 Then Rows(Target.Row + 1).Resize(CRowN - 1).EntireRow.Insert Sheets("Sheet2").Range(Sheets("Sheet2").Cells(4, i), Sheets("Sheet2").Cells(4 + CRowN - 1, i)).Copy (Sheets("Sheet1").Cells(Target.Row, 4)) Target.Offset(0, 1).Select Application.EnableEvents = True End If End Sub
[/vba]
Пришлось добавить строчку If Target.Value = "" Then CRowN = 0, ибо при удалении выбранного ранее значения в колонке С, макрос исправно удалял строки по количеству материала, а новые не находил и выпадал с ошибкой.
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
