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

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


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

Новости:

Подпишитесь на рассылку новых сообщений форума через службу рассылок: Subscribe.ru

Автор Тема: Определение таблицы по ее обрисованным границам.  (Прочитано 76 раз)

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

GWolf

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

Доброго времени суток, друзья!

На множестве листов (в примере их три) размещается табличка имеющая название "Таблица 1". Ее положение на каждом конкретном листе может быть отлично от ее расположения на других листах, но границы таблицы всегда начинаются на строку ниже, ячейки, в которой записано "Таблица 1" и в той же колонке. Сама таблица имеет разное количество объединенных ячеек по столбцам.
Поэтому есть мысль определить размерности таблицы по ее отрисованным границам. Но, вот как это сделать?
Помогите, пожалуйста!
Записан
Путей к вершине - множество. Этот один из многих!

boa

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

Добрый день, GWolf
макрос в окне Immediate впечатает адреса таблиц
Option Explicit

Sub NewMacros()
'' Author:  boa
'' Written: 25.10.2018
'' Edited:
'  Description:

    Dim Start!:           Start = Timer

Dim a As Range, iOfC&, iOfR, FirstValue$

With ActiveSheet
on error resume next
    Set a = .Cells.Find("таблица", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart)
    If a Is Nothing Then Exit Sub
    FirstValue = a.Value
    Do
        iOfC = 0
        Do
          If Not a.Offset(1, iOfC).Borders(xlEdgeRight).LineStyle = xlContinuous Then Exit Do
          iOfC = iOfC + 1
        Loop
       
        iOfR = 1
        Do
          If Not a.Offset(iOfR, 0).Borders(xlEdgeLeft).LineStyle = xlContinuous Then Exit Do
          iOfR = iOfR + 1
        Loop
       
        Debug.Print a.Value & ": " & Range(a.Offset(1, 0), a.Offset(iOfR - 1, iOfC - 1)).Address
       
        Set a = .Cells.FindNext(After:=a)
        If a.Value = FirstValue Then Exit Do
    Loop
   
End With
   
    Debug.Print "Затрачено: " & Timer - Start
End Sub
Но что бы границы правильно определялись, не должно быть "не заданных" границ(см.вложение jpg).
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

GWolf

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

Спасибо, уважаемый boa!
Все работает. Теперь буду "прикручивать" к своим нуждам.
А то я тут попытался решить проблему на моем уровне понимания, получилось координаты определить, но если в соседней, за таблицей, ячейке будет чего нибудь "забито", то все координаты летят!

Делал так:
Sub Стрелкавниз1_Щелчок()
    'предустановка значений таблицы 1, листа "SpisZn" в таблицах 1 листов
    Dim Sh As Worksheet
    Dim tPoint As Object
    Dim adrs As String
    Dim objR As Range
   
    With ThisWorkbook
        With .Worksheets("SpisZn")
        End With
       
        sct = .Worksheets.Count
       
        For Each Sh In .Worksheets
            'Sh.Cells(1, 1).Value = 1
            With Sh
                If .Name <> "SpisZn" And .Name <> "РАСЧЕТНАЯ ФОРМА" Then
                    Set tPoint = .Cells.Find("Таблица 1")
                   
                    If tPoint Is Nothing Then
                        adrs = "Нет такого заголовка на листе!"
                    Else
                        adrs = tPoint.Address
                    End If
                    Set tPoint = Nothing
                   
                    .Activate
                   
                    MsgBox "Лист № " & .Index & " (имя листа: " & .Name & ") из " & sct & " лист (-а, -ов)." & Chr(10) & "Адрес заголовка Таблица 1: " & adrs, , "Ищем адрес заголовка Таблица 1, на листах"

                    'выделение Таблицы 1
                    Set objR = .Range(adrs).Offset(1, 0)
                   
                    nRIn = objR.Row
                    nCIn = objR.Column

                    Set objR = objR.End(xlToRight)
                    Set objR = objR.End(xlDown)
                   
                    nRTo = objR.Row
                    nCTo = objR.Column

                    Set objR = Range(.Cells(nRIn, nCIn), .Cells(nRTo, nCTo))
                    objR.Select
                End If
            End With
        Next
    End With
End Sub
Записан
Путей к вершине - множество. Этот один из многих!
 



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

30.09.2018 10:24 Расчет процентов за определенный период (месяц) с учетом изменений и платежей 380
22.05.2018 11:38 Скрипт написать который допишет данные в файл 1041
03.03.2018 00:00 Подсчет отработанного времени, за исключением заранее определенных перерывов 1176
14.02.2018 10:11 Подготовить читабельную отчетность по платежам 1168
23.01.2018 13:46 Найти вероятность повторной покупки 1061
12.01.2018 23:56 Сделать отчет на Power BI (Dashboard) 1496
06.09.2017 10:43 Solver VBA не решает гиперболическое уравнение, но при этом решает гармоническое 1357
17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 1703
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 3440
15.03.2017 15:45 автозамена картинок PowerPoint 1954





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

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