Здравствуйте! Задача: Перейти по гиперссылке с помощь макроса. Нюансы: Гиперссылка динамическая и изменяется в зависимости от значения выбранного в выпадающем списке. Макрос должен запускаться с помощью кнопки. Вот что получается с помощью макро рекордера: [vba]
Код
Sub Макрос1() Range("D2").Select Application.Goto Reference:="Расходный!R4C1" End Sub
[/vba] Этот вариант не подходит, так-как при изменении адреса гиперссылки, адрес в макросе остается неизменным. Файл примера прилагается. Заранее всем спасибо!!! [moder]Для оформления кода используйте кнопку #[/moder]
Здравствуйте! Задача: Перейти по гиперссылке с помощь макроса. Нюансы: Гиперссылка динамическая и изменяется в зависимости от значения выбранного в выпадающем списке. Макрос должен запускаться с помощью кнопки. Вот что получается с помощью макро рекордера: [vba]
Код
Sub Макрос1() Range("D2").Select Application.Goto Reference:="Расходный!R4C1" End Sub
[/vba] Этот вариант не подходит, так-как при изменении адреса гиперссылки, адрес в макросе остается неизменным. Файл примера прилагается. Заранее всем спасибо!!! [moder]Для оформления кода используйте кнопку #[/moder]OIU
Как-то так (только у Вас немного неправильно диапазоны для списков заданы - только первая строка высвечивается) [vba]
Код
Sub tt() Dim R As Long Dim C As Long Dim Rng As Range With Application On Error Resume Next C = .WorksheetFunction.Match(Range("B2").Value, Range("РА11"), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If R = .WorksheetFunction.Match(Range("C2").Value, Sheets("Расходный").Columns(C), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If With Sheets("Расходный") Set Rng = .Range(.Cells(R, C), .Cells(R, C)) End With .Goto reference:=Rng End With End Sub
[/vba]
Как-то так (только у Вас немного неправильно диапазоны для списков заданы - только первая строка высвечивается) [vba]
Код
Sub tt() Dim R As Long Dim C As Long Dim Rng As Range With Application On Error Resume Next C = .WorksheetFunction.Match(Range("B2").Value, Range("РА11"), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If R = .WorksheetFunction.Match(Range("C2").Value, Sheets("Расходный").Columns(C), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If With Sheets("Расходный") Set Rng = .Range(.Cells(R, C), .Cells(R, C)) End With .Goto reference:=Rng End With End Sub
МВТ, да, так работает, но нужно не это) Вы видимо не проверили как работает ссылка. Ну ладно, не страшно) Ссылка нужна для добавления новых записей в столбцы. Если первая ячейка со списком пуста, то ссылка переносит тебя к первому пустому столбцу куда нужно добавить запись, а если пуста вторая ячейка со списком, то переходим к дополнению списка который выбран в первой ячейке.
МВТ, да, так работает, но нужно не это) Вы видимо не проверили как работает ссылка. Ну ладно, не страшно) Ссылка нужна для добавления новых записей в столбцы. Если первая ячейка со списком пуста, то ссылка переносит тебя к первому пустому столбцу куда нужно добавить запись, а если пуста вторая ячейка со списком, то переходим к дополнению списка который выбран в первой ячейке. OIU
(только у Вас немного неправильно диапазоны для списков заданы - только первая строка высвечивается)
Это потому что в старых версиях меньше количество строк на листе =65536, а в моём файле задано =1048576. Это исправил и список стал весь отображаться.OIU
МВТ, вот что мне удалось получить, подправив ваш код: [vba]
Код
Sub tt() Dim R As Long Dim C As Long Dim Rng As Range With Application On Error Resume Next C = .WorksheetFunction.Match(Range("B2").Value, Range("РА11"), 0) If Err Then Sheets("Расходный").Select Range("A1").Select Selection.End(xlToRight).Select Selection.Offset(0, 1).Select Exit Sub End If R = .WorksheetFunction.Match(Range("B2").Value, Sheets("Расходный").Columns(C), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If With Sheets("Расходный") Set Rng = .Range(.Cells(R, C), .Cells(R, C)) End With .Goto reference:=Rng End With Selection.End(xlDown).Select Selection.Offset(1, 0).Select End Sub
[/vba] И всё бы ничего... Но мне теперь кажется что тут остались лишние детали . А так, именно вот этого я и хотел добиться! Исправьте пожалуйста))) Буду вам очень признателен!
МВТ, вот что мне удалось получить, подправив ваш код: [vba]
Код
Sub tt() Dim R As Long Dim C As Long Dim Rng As Range With Application On Error Resume Next C = .WorksheetFunction.Match(Range("B2").Value, Range("РА11"), 0) If Err Then Sheets("Расходный").Select Range("A1").Select Selection.End(xlToRight).Select Selection.Offset(0, 1).Select Exit Sub End If R = .WorksheetFunction.Match(Range("B2").Value, Sheets("Расходный").Columns(C), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If With Sheets("Расходный") Set Rng = .Range(.Cells(R, C), .Cells(R, C)) End With .Goto reference:=Rng End With Selection.End(xlDown).Select Selection.Offset(1, 0).Select End Sub
[/vba] И всё бы ничего... Но мне теперь кажется что тут остались лишние детали . А так, именно вот этого я и хотел добиться! Исправьте пожалуйста))) Буду вам очень признателен! OIU
С уважением Евгений Ковель
Сообщение отредактировал OIU - Воскресенье, 18.10.2015, 22:07
Sub tt() Dim R As Long Dim C As Long On Error Resume Next C = WorksheetFunction.Match(Range("B2").Value, Range("РА11"), 0) If Err Then Application.Goto Sheets("Расходный").Cells(1).End(xlToRight).Next Exit Sub End If R = .WorksheetFunction.Match(Range("B2").Value, Sheets("Расходный").Columns(C), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If Application.Goto Sheets("Расходный").Cells(R, C).End(xlDown).Offset(1) End Sub
[/vba]
Добрый вечер! Как-то так: [vba]
Код
Sub tt() Dim R As Long Dim C As Long On Error Resume Next C = WorksheetFunction.Match(Range("B2").Value, Range("РА11"), 0) If Err Then Application.Goto Sheets("Расходный").Cells(1).End(xlToRight).Next Exit Sub End If R = .WorksheetFunction.Match(Range("B2").Value, Sheets("Расходный").Columns(C), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If Application.Goto Sheets("Расходный").Cells(R, C).End(xlDown).Offset(1) End Sub
Sub tt() Dim R As Long Dim C As Long On Error Resume Next C = WorksheetFunction.Match(Range("B2").Value, Range("РА11"), 0) If Err Then Application.Goto Sheets("Расходный").Cells(1).End(xlToRight).Next Exit Sub End If R = WorksheetFunction.Match(Range("B2").Value, Sheets("Расходный").Columns(C), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If Application.Goto Sheets("Расходный").Cells(R, C).End(xlDown).Offset(1) End Sub
[/vba]
да, там лишняя точка осталась. нужно так: [vba]
Код
Sub tt() Dim R As Long Dim C As Long On Error Resume Next C = WorksheetFunction.Match(Range("B2").Value, Range("РА11"), 0) If Err Then Application.Goto Sheets("Расходный").Cells(1).End(xlToRight).Next Exit Sub End If R = WorksheetFunction.Match(Range("B2").Value, Sheets("Расходный").Columns(C), 0) If Err Then MsgBox "Error", vbInformation Exit Sub End If Application.Goto Sheets("Расходный").Cells(R, C).End(xlDown).Offset(1) End Sub
KSV, спасибо! Теперь всё работает как нужно. А можете к коду еще добавить комментарии (описания)? Хочу понять что за что отвечает и какие действия выполняет. Заранее спасибо!
KSV, спасибо! Теперь всё работает как нужно. А можете к коду еще добавить комментарии (описания)? Хочу понять что за что отвечает и какие действия выполняет. Заранее спасибо! OIU
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
. А так, именно вот этого я и хотел добиться!
А можете к коду еще добавить комментарии (описания)? Хочу понять что за что отвечает и какие действия выполняет. Заранее спасибо! 
