Всех с наступившей Пасхой.. Не знаю, как написать макрос, который будет выводить значение ячейки из определенного столбца в ячейку А1 при выделении ячейки в определенном диапазоне строки. Т.е. если я выделил ячейку любую от A3 до H3, то в ячейке А1 должно появиться значение ячейки J3.
Всех с наступившей Пасхой.. Не знаю, как написать макрос, который будет выводить значение ячейки из определенного столбца в ячейку А1 при выделении ячейки в определенном диапазоне строки. Т.е. если я выделил ячейку любую от A3 до H3, то в ячейке А1 должно появиться значение ячейки J3.ovechkin1973
Такой вариант. Возможно выделение нескольких ячеек, не все из которых могут принадлежать диапазону А3:Н18
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim d_ As Range r0_ = 3 r1_ = Range("J" & Rows.Count).End(xlUp).Row Set d_ = Intersect(Target, Range("A3").Resize(r1_ - r_ + 1, 8)) If Not d_ Is Nothing Then Range("A1") = Cells(d_(1).Row, "J").Value End If End Sub
[/vba]
Добавлено Если вообще ни одна ячейка не принадлежит указанному выше диапазону, то А1 очищаетсся (файл _2)
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim d_ As Range r0_ = 3 r1_ = Range("J" & Rows.Count).End(xlUp).Row Set d_ = Intersect(Target, Range("A3").Resize(r1_ - r_ + 1, 8)) If Not d_ Is Nothing Then Range("A1") = Cells(d_(1).Row, "J").Value Else Range("A1").ClearContents End If End Sub
[/vba]
Такой вариант. Возможно выделение нескольких ячеек, не все из которых могут принадлежать диапазону А3:Н18
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim d_ As Range r0_ = 3 r1_ = Range("J" & Rows.Count).End(xlUp).Row Set d_ = Intersect(Target, Range("A3").Resize(r1_ - r_ + 1, 8)) If Not d_ Is Nothing Then Range("A1") = Cells(d_(1).Row, "J").Value End If End Sub
[/vba]
Добавлено Если вообще ни одна ячейка не принадлежит указанному выше диапазону, то А1 очищаетсся (файл _2)
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim d_ As Range r0_ = 3 r1_ = Range("J" & Rows.Count).End(xlUp).Row Set d_ = Intersect(Target, Range("A3").Resize(r1_ - r_ + 1, 8)) If Not d_ Is Nothing Then Range("A1") = Cells(d_(1).Row, "J").Value Else Range("A1").ClearContents End If End Sub
Хорошо, что есть профи! Огромное человеческое! приспособил второй вариант макроса к своему файлу.. обнаружил две проблемы.. одна не существенная - у меня данные с 10-ой строки начинаются, выше идет шапка таблицы. Если встать на ячейку выше 10-ой строки, то выскакивает ошибка 1004 "изменить часть объединенной ячейки не возможно".. это я переживу. А вторая проблема.. у меня на рабочем листе есть уже код, который начинается на Private Sub Worksheet_SelectionChange(ByVal Target As Range). В нем около 10 строк, а найти как под спойлер спрятать не пойму как.. И чтобы работал один макрос приходиться за комментировать другой
Хорошо, что есть профи! Огромное человеческое! приспособил второй вариант макроса к своему файлу.. обнаружил две проблемы.. одна не существенная - у меня данные с 10-ой строки начинаются, выше идет шапка таблицы. Если встать на ячейку выше 10-ой строки, то выскакивает ошибка 1004 "изменить часть объединенной ячейки не возможно".. это я переживу. А вторая проблема.. у меня на рабочем листе есть уже код, который начинается на Private Sub Worksheet_SelectionChange(ByVal Target As Range). В нем около 10 строк, а найти как под спойлер спрятать не пойму как.. И чтобы работал один макрос приходиться за комментировать другой
Set d_ = Intersect(Target, Range("A3").Resize(r1_ - r_ + 1, 8))
1. Я неверно написал, вместо r_ нужно написать r0_. И, если у Вас начало со строки 10, то в макросе 3-я строка r0_= не 3, а 10. Файл перевложил. 2. Под спойлер не нужно, нужно положить код, выделить его и нажать кнопку # (которая рядом с кнопкой fx). А спойлер это только если код большой или если их много, чтобы пост не загромождать, но это не обязательно
Set d_ = Intersect(Target, Range("A3").Resize(r1_ - r_ + 1, 8))
1. Я неверно написал, вместо r_ нужно написать r0_. И, если у Вас начало со строки 10, то в макросе 3-я строка r0_= не 3, а 10. Файл перевложил. 2. Под спойлер не нужно, нужно положить код, выделить его и нажать кнопку # (которая рядом с кнопкой fx). А спойлер это только если код большой или если их много, чтобы пост не загромождать, но это не обязательно_Boroda_
похоже я или совсем не внимателен или еще какой вирус в голове.. приложил шаблон реальной таблицы. Если выходить за диапазон выделенных синей заливкой ячеек - выпадает ошибка.. и если на зеленые ячейки вставать тот же результат, а не хотелось вообще ошибок. Нет что бы сразу нужный файл (с нужной шапкой) приложить... давыеживался.. Ну и код, который закомментирован в приложенном файле есть. Как оба маркроса заставить работать не представляю. Автор кода не я.. помогли люди.. я им нажимая на стрелочки двигаю влево или вправо содержимое ячеек по "кругу" [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim d_ As Range r0_ = 10 r1_ = Range("AU" & Rows.Count).End(xlUp).Row Set d_ = Intersect(Target, Range("A10").Resize(r1_ - r0_ + 1, 45)) If Not d_ Is Nothing Then Range("R1") = Cells(d_(1).Row, "AU").Value Else Range("R1").ClearContents End If End Sub
'ÇÀÏÎËÍÅÍÈÅ ÌÀÑÑÈÂÀ ÄÀÍÍÛÌÈ ÏÅÐÅÎÄÈ×ÍÎÑÒÈ 'Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' On Error Resume Next ' Application.ScreenUpdating = False ' SELEST = Target.Text ' If Target.Column > 22 And Target.Column < 39 And Target.Row > 10 Then ' r = Target.Row ' SpinButton1.Visible = False ' SpinButton1.Top = Target.Top ' SpinButton1.Left = Ëèñò2.Columns(22).Left ' SpinButton1.Height = Target.Height ' SpinButton1.Width = Ëèñò2.Columns(22).Width ' SpinButton1.Visible = True ' Call CHANGE_MASSIV(Target) ' End If 'End Sub
[/vba]
похоже я или совсем не внимателен или еще какой вирус в голове.. приложил шаблон реальной таблицы. Если выходить за диапазон выделенных синей заливкой ячеек - выпадает ошибка.. и если на зеленые ячейки вставать тот же результат, а не хотелось вообще ошибок. Нет что бы сразу нужный файл (с нужной шапкой) приложить... давыеживался.. Ну и код, который закомментирован в приложенном файле есть. Как оба маркроса заставить работать не представляю. Автор кода не я.. помогли люди.. я им нажимая на стрелочки двигаю влево или вправо содержимое ячеек по "кругу" [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim d_ As Range r0_ = 10 r1_ = Range("AU" & Rows.Count).End(xlUp).Row Set d_ = Intersect(Target, Range("A10").Resize(r1_ - r0_ + 1, 45)) If Not d_ Is Nothing Then Range("R1") = Cells(d_(1).Row, "AU").Value Else Range("R1").ClearContents End If End Sub
'ÇÀÏÎËÍÅÍÈÅ ÌÀÑÑÈÂÀ ÄÀÍÍÛÌÈ ÏÅÐÅÎÄÈ×ÍÎÑÒÈ 'Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' On Error Resume Next ' Application.ScreenUpdating = False ' SELEST = Target.Text ' If Target.Column > 22 And Target.Column < 39 And Target.Row > 10 Then ' r = Target.Row ' SpinButton1.Visible = False ' SpinButton1.Top = Target.Top ' SpinButton1.Left = Ëèñò2.Columns(22).Left ' SpinButton1.Height = Target.Height ' SpinButton1.Width = Ëèñò2.Columns(22).Width ' SpinButton1.Visible = True ' Call CHANGE_MASSIV(Target) ' End If 'End Sub
......... многоточие, это мат в отношении себя.. как до домашнего компа доберусь- скину.. не правильно я понял Ваш ответ, про "не хорошо обманывать"
......... многоточие, это мат в отношении себя.. как до домашнего компа доберусь- скину.. не правильно я понял Ваш ответ, про "не хорошо обманывать"ovechkin1973
Плохо когда не знаешь, да еще забудешь. Правильно сформулированный вопрос содержит половину ответа.
[/vba] По поводу закомментированного куска - объясните лучше словами что он должен делать и по каким условиям. И что за макрос или функция CHANGE_MASSIV? У Вас в файле нет такого
Перепишите 3-ю снизу строку вот так [vba]
Код
Range("R1:T3").ClearContents
[/vba] По поводу закомментированного куска - объясните лучше словами что он должен делать и по каким условиям. И что за макрос или функция CHANGE_MASSIV? У Вас в файле нет такого_Boroda_
Спасибо, доработка 3 строки снизу помогло. по поводу макроса или функции не скажу.. в экселе практически нуль.. с макросах тем более.. могу только их сохранить на лист или книгу и к кнопке привязать. В том файле, что для примера выложил ничего нет.. в "родном" файле их много и писал их не я.. Возможно я не весь код выложил..моих знаний понять что и где не хватает. Копирую кода побольше, может вам станет тогда понятнее.. Надеюсь, за то, что правила немного нарушил мне на орехи от вас не достанется.. не по теме однако пишу. В конце концов вы модератор и можете все, что нельзя удалить. Обидно только, что код который вы мне написали и код, который был на моем листе начинаются с Private Sub Worksheet_SelectionChange(ByVal Target As Range) и одновременно не работают
[vba]
Код
Перемещение периодичности Private Sub SpinButton1_Change() Dim STATUS As Boolean: STATUS = False On Error Resume Next If PASS = "12345" Then STATUS = True PASS = "12345" Application.ScreenUpdating = False If SpinButton1.Value = 2 Or SpinButton1.Value + 16 = 999 Then Call MsgBox("Ïðåäåë ìàññèâà äîñòãíóò", vbCritical, "Õâàòèò èãðàòüñÿ") SpinButton1.Value = 500 Exit Sub End If Ëèñò2.Cells(r, 23).Value = array_round(SpinButton1.Value - 15) Ëèñò2.Cells(r, 24).Value = array_round(SpinButton1.Value - 14) Ëèñò2.Cells(r, 25).Value = array_round(SpinButton1.Value - 13) Ëèñò2.Cells(r, 26).Value = array_round(SpinButton1.Value - 12) Ëèñò2.Cells(r, 27).Value = array_round(SpinButton1.Value - 11) Ëèñò2.Cells(r, 28).Value = array_round(SpinButton1.Value - 10) Ëèñò2.Cells(r, 29).Value = array_round(SpinButton1.Value - 9) Ëèñò2.Cells(r, 30).Value = array_round(SpinButton1.Value - 8) Ëèñò2.Cells(r, 31).Value = array_round(SpinButton1.Value - 7) Ëèñò2.Cells(r, 32).Value = array_round(SpinButton1.Value - 6) Ëèñò2.Cells(r, 33).Value = array_round(SpinButton1.Value - 5) Ëèñò2.Cells(r, 34).Value = array_round(SpinButton1.Value - 4) Ëèñò2.Cells(r, 35).Value = array_round(SpinButton1.Value - 3) Ëèñò2.Cells(r, 36).Value = array_round(SpinButton1.Value - 2) Ëèñò2.Cells(r, 37).Value = array_round(SpinButton1.Value - 1) Ëèñò2.Cells(r, 38).Value = array_round(SpinButton1.Value) If STATUS = False Then PASS = Empty End Sub
Заполнение массива данными переодичности 'Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' On Error Resume Next ' Application.ScreenUpdating = False ' SELEST = Target.Text ' If Target.Column > 22 And Target.Column < 39 And Target.Row > 10 Then ' r = Target.Row ' SpinButton1.Visible = False ' SpinButton1.Top = Target.Top ' SpinButton1.Left = Ëèñò2.Columns(22).Left ' SpinButton1.Height = Target.Height ' SpinButton1.Width = Ëèñò2.Columns(22).Width ' SpinButton1.Visible = True ' Call CHANGE_MASSIV(Target) ' End If 'End Sub
[/vba]
Спасибо, доработка 3 строки снизу помогло. по поводу макроса или функции не скажу.. в экселе практически нуль.. с макросах тем более.. могу только их сохранить на лист или книгу и к кнопке привязать. В том файле, что для примера выложил ничего нет.. в "родном" файле их много и писал их не я.. Возможно я не весь код выложил..моих знаний понять что и где не хватает. Копирую кода побольше, может вам станет тогда понятнее.. Надеюсь, за то, что правила немного нарушил мне на орехи от вас не достанется.. не по теме однако пишу. В конце концов вы модератор и можете все, что нельзя удалить. Обидно только, что код который вы мне написали и код, который был на моем листе начинаются с Private Sub Worksheet_SelectionChange(ByVal Target As Range) и одновременно не работают
[vba]
Код
Перемещение периодичности Private Sub SpinButton1_Change() Dim STATUS As Boolean: STATUS = False On Error Resume Next If PASS = "12345" Then STATUS = True PASS = "12345" Application.ScreenUpdating = False If SpinButton1.Value = 2 Or SpinButton1.Value + 16 = 999 Then Call MsgBox("Ïðåäåë ìàññèâà äîñòãíóò", vbCritical, "Õâàòèò èãðàòüñÿ") SpinButton1.Value = 500 Exit Sub End If Ëèñò2.Cells(r, 23).Value = array_round(SpinButton1.Value - 15) Ëèñò2.Cells(r, 24).Value = array_round(SpinButton1.Value - 14) Ëèñò2.Cells(r, 25).Value = array_round(SpinButton1.Value - 13) Ëèñò2.Cells(r, 26).Value = array_round(SpinButton1.Value - 12) Ëèñò2.Cells(r, 27).Value = array_round(SpinButton1.Value - 11) Ëèñò2.Cells(r, 28).Value = array_round(SpinButton1.Value - 10) Ëèñò2.Cells(r, 29).Value = array_round(SpinButton1.Value - 9) Ëèñò2.Cells(r, 30).Value = array_round(SpinButton1.Value - 8) Ëèñò2.Cells(r, 31).Value = array_round(SpinButton1.Value - 7) Ëèñò2.Cells(r, 32).Value = array_round(SpinButton1.Value - 6) Ëèñò2.Cells(r, 33).Value = array_round(SpinButton1.Value - 5) Ëèñò2.Cells(r, 34).Value = array_round(SpinButton1.Value - 4) Ëèñò2.Cells(r, 35).Value = array_round(SpinButton1.Value - 3) Ëèñò2.Cells(r, 36).Value = array_round(SpinButton1.Value - 2) Ëèñò2.Cells(r, 37).Value = array_round(SpinButton1.Value - 1) Ëèñò2.Cells(r, 38).Value = array_round(SpinButton1.Value) If STATUS = False Then PASS = Empty End Sub
Заполнение массива данными переодичности 'Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' On Error Resume Next ' Application.ScreenUpdating = False ' SELEST = Target.Text ' If Target.Column > 22 And Target.Column < 39 And Target.Row > 10 Then ' r = Target.Row ' SpinButton1.Visible = False ' SpinButton1.Top = Target.Top ' SpinButton1.Left = Ëèñò2.Columns(22).Left ' SpinButton1.Height = Target.Height ' SpinButton1.Width = Ëèñò2.Columns(22).Width ' SpinButton1.Visible = True ' Call CHANGE_MASSIV(Target) ' End If 'End Sub
Попросил автора кода добавить мой код. Выглядит так. Все работает [vba]
Код
'ЗАПОЛНЕНИЕ МАССИВА ДАННЫМИ ПЕРИОДИЧНОСТИ Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.ScreenUpdating = False On Error Resume Next SELEST = Target.Text If Target.Column > 22 And Target.Column < 39 And Target.Row > 9 Then r = Target.Row 'ТУТ ВЫРАВНИВАЕМ КОНТРОЛ ПО ВЫБРАННОЙ СТРОКЕ В УКАЗАННОМ ДИАПАЗОНЕ SpinButton1.Visible = False SpinButton1.Top = Target.Top SpinButton1.Left = Лист2.Columns(22).Left SpinButton1.Height = Target.Height SpinButton1.Width = Лист2.Columns(22).Width SpinButton1.Visible = True 'ЗАПОЛНЕНИЕ МАССИВА ДАННЫМИ ПЕРЕОДИЧНОСТИ Call CHANGE_MASSIV(Target) End If 'ВАШ МАКРОС====================================================================== Dim d_ As Range r0_ = 1 r1_ = Range("AU" & Rows.Count).End(xlUp).Row Set d_ = Intersect(Target, Range("A10").Resize(r1_ - r_ + 1, 45)) If Not d_ Is Nothing Then Range("R1") = Cells(d_(1).Row, "AU").Value Else Range("R1:T3").ClearContents
End If '===================================================================================== End Sub
[/vba]
Попросил автора кода добавить мой код. Выглядит так. Все работает [vba]
Код
'ЗАПОЛНЕНИЕ МАССИВА ДАННЫМИ ПЕРИОДИЧНОСТИ Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.ScreenUpdating = False On Error Resume Next SELEST = Target.Text If Target.Column > 22 And Target.Column < 39 And Target.Row > 9 Then r = Target.Row 'ТУТ ВЫРАВНИВАЕМ КОНТРОЛ ПО ВЫБРАННОЙ СТРОКЕ В УКАЗАННОМ ДИАПАЗОНЕ SpinButton1.Visible = False SpinButton1.Top = Target.Top SpinButton1.Left = Лист2.Columns(22).Left SpinButton1.Height = Target.Height SpinButton1.Width = Лист2.Columns(22).Width SpinButton1.Visible = True 'ЗАПОЛНЕНИЕ МАССИВА ДАННЫМИ ПЕРЕОДИЧНОСТИ Call CHANGE_MASSIV(Target) End If 'ВАШ МАКРОС====================================================================== Dim d_ As Range r0_ = 1 r1_ = Range("AU" & Rows.Count).End(xlUp).Row Set d_ = Intersect(Target, Range("A10").Resize(r1_ - r_ + 1, 45)) If Not d_ Is Nothing Then Range("R1") = Cells(d_(1).Row, "AU").Value Else Range("R1:T3").ClearContents
End If '===================================================================================== End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
