Профессиональные приемы работы в Microsoft Excel

Пожалуйста, войдите или зарегистрируйтесь.


Расширенный поиск  

Новости:

Читайте новые сообщения форума форума в RRS-агрегаторах

Автор Тема: Переход с листа на лист по двойному клику мышки в ячейке  (Прочитано 80 раз)

0 Пользователей и 1 Гость просматривают эту тему.

GWolf

  • Старожил
  • ****
  • Уважение: +50/-0
  • Оффлайн Оффлайн
  • Сообщений: 928

Доброго времени суток!

На событие листа SheetBeforeDoubleClick, в модуле ЭтаКнига "навесил" следующий макрос:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim c As Range
   
    Select Case Sh.Name
        Case "mtd"
   
            Set c = Range([A5], Sh.Cells(LastRow(Sh.Name) + 1, 1))

            If Not Intersect(c, Target) Is Nothing And Target.Text = "" Then '<<< Intersect
                With ThisWorkbook.Worksheets("BDMarsrutS")
                   
                    .Activate
                End With
            End If
    End Select
End Sub

Function LastRow(wSt As String) As Long
    Dim ra As Excel.Range, Item As Excel.Range
   
    Set ra = Worksheets(wSt).Cells.SpecialCells(2)    ' возвращает все ячейки со значениями
   
    LastRow = 0

    For Each Item In ra.EntireRow.Rows
        If Item.Row > LastRow Then LastRow = Item.Row
    Next Item
    Set ra = Nothing
End Function
, т.о. организовал переход с листа "mtd" на лист "BDMarsrutS".
Теперь, хотелось бы по ДКМ на листе "BDMarsrutS" вернуться на лист "mtd" и в строку, ячейки, откуда стартовал занести данные из ячейки листа "BDMarsrutS", по которой щелкнул ДКМ.

Один способ я знаю: при выполнении 1-й части, т.е.  ДКМ на листе "mtd", сохранять nR и nC стартовой ячейки на вспомогательном листе "ust". А при ДКМ на листе "BDMarsrutS", считывать эти значения в переменные, как координаты ячейки возврата. Вот так:Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim c As Range '
    Dim arrN() As String '
    Dim i As Long '
    Dim nRTo As Long '
    Dim nCTo As Long '
    Dim wsNmeTo As String '
    Dim wbNmeTo As String '
   
    Select Case Sh.Name
        Case "mtd"
   
            Set c = Range([A5], Sh.Cells(LastRow(Sh.Name) + 1, 1))

            If Not Intersect(c, Target) Is Nothing And Target.Text = "" Then '<<< Intersect
                With ThisWorkbook
                    With .Worksheets("ust")
                        .Cells(2, 1) = Target.Row '
                        .Cells(3, 1) = Target.Column '
                        .Cells(4, 1) = Sh.Name '
                        .Cells(5, 1) = ThisWorkbook.Name '
                    End With
                    With .Worksheets("BDMarsrutS")
                        .Activate
                    End With
                End With
            End If
           
            Set c = Nothing
        Case "BDMarsrutS"
            If Target.Column = 1 Then
                i = 0
                For i = 1 To 5
                    If i = 1 Then
                        ReDim arrN(i - 1)
                        arrN(i - 1) = Target.Text
                    Else
                        ReDim Preserve arrN(i - 1)
                        arrN(i - 1) = Target.Offset(, i).Text
                    End If
                Next i
               
                With ThisWorkbook
                    With .Worksheets("ust")
                        nRTo = .Cells(2, 1).Value '
                        nCTo = .Cells(3, 1).Value '
                        wsNmeTo = .Cells(4, 1).Text '
                        wbNmeTo = .Cells(5, 1).Text '
                    End With
                   
                    With .Worksheets("mtd")
                        .Activate
                        i = 0
                        For i = LBound(arrN) To UBound(arrN)
                            .Cells(nRTo, i + 1) = arrN(i)
                        Next i
                       
                        Erase arrN
                    End With
                End With
            End If
    End Select
End Sub

Function LastRow(wSt As String) As Long
    Dim ra As Excel.Range, Item As Excel.Range
   
    Set ra = Worksheets(wSt).Cells.SpecialCells(2)    ' возвращает все ячейки со значениями
   
    LastRow = 0

    For Each Item In ra.EntireRow.Rows
        If Item.Row > LastRow Then LastRow = Item.Row
    Next Item
    Set ra = Nothing
End Function


Но, нельзя ли при возврате как-то обратится к ячейке старта? Без сохранения ее координат.

Вроде объяснил. Если не понятно объясню еще. Может кто знает решение?

« Последнее редактирование: 21.11.2018, 14:07:43 от GWolf »
Записан
Путей к вершине - множество. Этот один из многих!

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +32/-0
  • Оффлайн Оффлайн
  • Сообщений: 543
  • Доброта спасет мир...

Здравствуйте,
В обыкновенном модуле объявите Паблик переменную, например:
Public MeRange As Rangeпотом переходя в одну сторону присваиваете ей значение
Set MeRange = Target а возвращаясь, считываете из неё.
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра
 



Темы без ответов

30.09.2018 10:24 Расчет процентов за определенный период (месяц) с учетом изменений и платежей 464
03.03.2018 00:00 Подсчет отработанного времени, за исключением заранее определенных перерывов 1266
14.02.2018 10:11 Подготовить читабельную отчетность по платежам 1264
23.01.2018 13:46 Найти вероятность повторной покупки 1150
12.01.2018 23:56 Сделать отчет на Power BI (Dashboard) 1614
06.09.2017 10:43 Solver VBA не решает гиперболическое уравнение, но при этом решает гармоническое 1416
17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 1807
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 3609
15.03.2017 15:45 автозамена картинок PowerPoint 2046
11.03.2017 13:43 Изменить нумерацию страниц 2164





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.111 секунд. Запросов: 103.