mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Функция получения ссылки на заданную пользователем ячейку

Зачастую требуется в функциях ввести дополнительный параметр, где пользователь может задать ссылку на ячейку
(например, место для вставки данных)

Поскольку фантазия некоторых пользователей ничем не ограничена, да и хочется сделать макрос универсальным, необходимо сделать так, чтобы пользователь мог задать параметр ЯчейкаДляВставки в любом виде - будь то ссылка на ячейку, строку или столбец, или же имя столбца или номер строки.
Если же ни одной книги Excel в данный момент не открыто, - макрос должен догадаться, что необходимо создать новую книгу, содержащую один лист.

Потому и была написана функция GetCell, которую можно использовать следующим образом:

Sub ПримерИспользования_GetCell()
    ' вставляем значение в первую пустую ячейку столбца A
    ' (вставка производится ниже всех данных в первом столбце листа)
    GetCell("a").Value = Now
 
    ' то же самое, но с другими вариантами параметра функции (все 4 способа равнозначны)
    GetCell("a:a").Value = 111
    GetCell(Columns(1)).Value = 222
    GetCell([a:a]).Value = 333
 
    '  ============ вставка в первую незаполненную ячейку третьей строки =================
    GetCell(Destination:=3).Value = 1
    ' то же самое, но с другими вариантами параметра функции (все 4 способа равнозначны)
    GetCell("3").Value = 2
    GetCell(Rows(3)).Value = 3
    GetCell([3:3]).Value = 4
 
    '  ============ другие варианты использования =================
    GetCell().Value = "активная ячейка"    ' вставка в заданную ячейку (вызов без параметра)
    GetCell("NewSheet").Value = "на новый лист в ячейку A1"    ' создаётся новый лист
    GetCell("NewWorkbook").Value = "в новую книгу в ячейку A1"    ' создаётся новая книга Excel
End Sub

Как вы заметили, в качестве параметра функции можно использовать предопределённые текстовые константы "NewSheet" и "NewWorkbook"

Код функции GetCell:

Пример использования функции GetCell можно посмотреть
в надстройке для импорта данных из CSV на лист Excel

Function GetCell(Optional ByRef Destination As Variant) As Range
    ' Функция получает в качестве параметра ссылку на диапазон
    ' Возвращает ячейку для вставки данных в зависимости от параметра:
    '   если параметр не задан - возвращается активная ячейка текущей книги
    '   если параметр является ссылкой на ячейку - возвращается эта ячейка
    '   если параметр является ссылкой на строку - возвращается первая незаполненная ячейка этой строки
    '   если параметр является ссылкой на столбец - возвращается первая незаполненная ячейка этого столбца

    On Error Resume Next: Err.Clear
    If IsMissing(Destination) Then
        If ActiveWorkbook Is Nothing Then Workbooks.Add(xlWBATWorksheet).Worksheets(1).Name = "Данные"
        Set GetCell = ActiveCell: Exit Function
    End If
 
    If Not IsObject(Destination) Then If IsNumeric(Destination) Then Destination = Val(Destination)
 
    Select Case TypeName(Destination)
        Case "String"
            If Destination = "NewWorkbook" Then Workbooks.Add(xlWBATWorksheet).Worksheets(1).Name = "Данные"
            If ActiveWorkbook Is Nothing Then Workbooks.Add(xlWBATWorksheet).Worksheets(1).Name = "Данные"
 
            If Destination = "NewSheet" Then ActiveWorkbook.Worksheets.Add , ActiveSheet
 
            Set GetCell = Range(Destination)
            If Err.Number = 1004 Then
                If Destination Like String(Len(Destination), "[A-z]") Then _
                   Err.Clear: Set GetCell = Range(Destination & ":" & Destination)
                'Debug.Print Err.Number, Err.Description
                If Err Then Set GetCell = ActiveCell: Exit Function    ' неопознанная ошибка
            End If
        Case "Integer", "Long", "Double"
            If ActiveWorkbook Is Nothing Then Workbooks.Add(xlWBATWorksheet).Worksheets(1).Name = "Данные"
            Err.Clear: If Val(Destination) > 0 Then Set GetCell = Rows(Val(Destination))
            If Err Then Set GetCell = ActiveCell: Exit Function    ' неопознанная ошибка

        Case "Range": Set GetCell = Destination
        Case "Workbook": Set GetCell = Destination.Worksheets(1).[a:a]
        Case "Worksheet": Set GetCell = Destination.[a:a]
 
        Case Else
            Debug.Print "Another parameter type: ", TypeName(Destination)
            Set GetCell = ActiveCell: Exit Function    ' неопознанная ошибка
    End Select
 
    If GetCell Is Nothing Then Set GetCell = ActiveCell: Exit Function
    Select Case True
        Case GetCell.Address = GetCell.EntireColumn.Address
            Set GetCell = GetCell.Columns(1).Cells(GetCell.Rows.Count).End(xlUp).Offset(1)
        Case GetCell.Address = GetCell.EntireRow.Address
            Set GetCell = GetCell.Rows(1).Cells(GetCell.Columns.Count).End(xlToLeft).Offset(, 1)
        Case Else: Set GetCell = GetCell.Cells(1)
 
    End Select
End Function

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Сергей, так попробуйте:
(вместо B4 подставив адрес нужной ячейки)

msgbox Range("B4").Hyperlinks(1).address

Подскажите пожалуйста, как получить ссылку из конкретной ячейки? Ссылка записана не через =ГИПЕРССЫЛКА("";""), а именно в ячейку (как мне ее вернуть?).

Спасибо.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _____   _____   _                 __   __
|___ | | ___| / | __ __ ___ \ \ / /
/ / | |_ | | \ \ / / / __| \ V /
/ / | _| | | \ V / | (__ | |
/_/ |_| |_| \_/ \___| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.