Макрос для копирования и совмещения динамических таблиц

vtb

Добрый день, уважаемые коллеги!

Задача - сделать макрос, который будет копировать на один лист две таблицы с двух других листов.
Количество строк и столбцов в таблицах может изменяться, но при этом они должны оказываться одна под другой без промежутков.

Никак не удается добиться, чтобы макрос считал количество строк в верхней таблице и вставлял нижнюю сразу же после верхней, без промежутков.
Может кто-то уже сталкивался с чем-то подобным?

пока что есть следующий код:

Sub copymacro(ParamArray varname())
Dim resultArea As Range
Set resultArea = varname(1)

Dim srcws As Worksheet
Dim destws As Worksheet
Dim src_row As Integer, src_col As Integer, dest_row As Integer, dest_col As Integer, n As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

If varname(0) = "DP_1" Then
Set srcws = ThisWorkbook.Worksheets("Лист1")
Set destws = ThisWorkbook.Worksheets("Итоговый лист")
destws.Activate
'Копируем из src_row = 1 src_col = 1
'Копируем в dest_row = 6 dest_col = 2
Call ClearForm(destws, dest_row, 1)
If IsEmpty(resultArea.Cells(src_row, 1)) Then
destws.Range("A" & dest_row).Value = "Данные отсутствуют!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End If

Call CopyData(resultArea, src_row, src_col, destws, dest_row, dest_col, -1, resultArea.Columns.Count - src_col + 1)

Call FormatForm(destws, dest_row)
End If
If varname(0) = "DP_2" Then
Set srcws = ThisWorkbook.Worksheets("Лист 2")
Set destws = ThisWorkbook.Worksheets("Итоговый лист")
destws.Activate
'Копируем из src_row = 1 src_col = 1
'Копируем в dest_row = 18 dest_col = 2
If IsEmpty(resultArea.Cells(src_row, 1)) Then
destws.Range("A" & dest_row).Value = "Данные отсутствуют!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End If
Call CopyData(resultArea, src_row, src_col, destws, dest_row, dest_col, -1, resultArea.Columns.Count - src_col + 1)
Call FormatForm(destws, dest_row)
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

Заранее спасибо!

ash

Приветствую!

Если я правильно понял, то макрос отрабатывает при открытии книги. Предлагаю следующий алгоритм:
1. в макросе при открытии определять координаты обеих таблиц и записывать их, допустим, в массив;
2. в последнем вызове макроса (читай для поседней таблицы) вызывать свою процедуру;
3. в процедуре копировать/вставлять таблицы доставая их координаты из массива (и, соответственно, вычисляя количество строк) удобным для Вас способом.

vtb

ash написал:

Приветствую!

Если я правильно понял, то макрос отрабатывает при открытии книги. Предлагаю следующий алгоритм:
1. в макросе при открытии определять координаты обеих таблиц и записывать их, допустим, в массив;
2. в последнем вызове макроса (читай для поседней таблицы) вызывать свою процедуру;
3. в процедуре копировать/вставлять таблицы доставая их координаты из массива (и, соответственно, вычисляя количество строк) удобным для Вас способом.

спасибо, но, честно говоря, я не знаю, как написать такой код.

ROKO

vtb написал:

спасибо, но, честно говоря, я не знаю, как написать такой код.

Посмотрите вот здесь.

ash

vtb написал:

спасибо, но, честно говоря, я не знаю, как написать такой код.

Вот что я имел ввиду:
1. Макрос при открытии книги (отрабатывает равное количеству табличных запросов в книге раз):

Code:

Public Const qCnt As Integer = 4                'количество запросов
Public arrID(1 To qCnt, 1 To 5) As Variant      'Массив с координатами запросов
Public i As Integer                             'счетчик

Public Sub SAPBExOnRefresh(queryID As String, resultArea As Range)

  i = i + 1
  With resultArea                               'создаем массив координат запросов
    arrID(i, 1) = queryID                       ' имя запроса
    arrID(i, 2) = .Row                          ' первая строка
    arrID(i, 3) = .Column                       ' первый столбец
    arrID(i, 4) = .Row + .Rows.Count - 1        ' последняя строка
    arrID(i, 5) = .Column + .Columns.Count - 1  ' последний столбец   
  End With
  
  If i = qCnt Then      'если активный запрос - последний
    i = 0               'обнуление счетчика запросов для последующего запуска
    'Call ....          'Запуск процедуры копирования таблиц
  End If
End Sub

Далее, в макрос вставляем условие, если запрос последний, то запускаем свою процедуру копирования.

vtb

ROKO написал:

vtb написал:

спасибо, но, честно говоря, я не знаю, как написать такой код.

Посмотрите вот здесь.

спасибо!

vtb

ash написал:

vtb написал:

спасибо, но, честно говоря, я не знаю, как написать такой код.

Вот что я имел ввиду:
1. Макрос при открытии книги (отрабатывает равное количеству табличных запросов в книге раз):

Code:

........................................

Далее, в макрос вставляем условие, если запрос последний, то запускаем свою процедуру копирования.

Огромное спасибо! Будем пробовать!

bream

Последовательность вызова макросов определяется через номер его привязку к грид.
Просто нужно писать количество строк отчета 1 на скрытый лист, и когда макрос отрабатывает второй раз, считывать это количество и суммировать с текущим.

G

Мои 5 копеек. Как бы сделал я:
1. Создал бы два именованных диапазона на листе, где сливаются отчеты.
2. Можно даже смело назвать именованные диапазоны как провайдеры в книге DP_1 и DP_2
3. В колбеке я бы очищал диапазон соответствующий провайдеру от данных, потом добавлял или удалял из него строки до количества строк в отчете.
4. После приведения количества строк в соответствие -- область заполнить данными.

Критика предложенных решений:

1. Все предложенные решения оперируют несуществующим понятием "последний вызов". На практике последний вызов совершается для первого добавленного в книгу отчета. Но все равно стремный вариант. Непонятно зачем на это опираться.

2. Внутренние массивы неприятны тем, что форматирование придется создавать руками, а не копировать из готовых и отформатированных Bex-отчетов, и если есть валюта и единица измерения, вообще все кодоемко будет.

3. Избавьтесь от такой конструкции:

Code:

Set destws = ThisWorkbook.Worksheets("Итоговый лист")

Привязывайтесь к листу любыми другими способами.

4. Для отрубания реакций экселя используйте только конструкцию с обработкой ошибок, иначе эксель будет "подвисать":

Code:

Sub Output(ByVal Text As String, ByVal Level As Integer)
       
    If Not (Err Is Nothing) Then
        If Err.Number <> 0 Then
            Text = Text & _
                vbCrLf & "Номер: " & Err.Number & _
                vbCrLf & "Описание: " & Err.Description & _
                vbCrLf & "Место возникновения: " & Err.Source
            Level = vbCritical
        End If
    End If
    
    Call MsgBox(Text, vbOKOnly + Level, MsgBoxTitle)
    
End Sub

Sub ExlUnfreeze()
    Application.Interactive = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic 
End Sub
....
    Application.Interactive = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual     
    
    On Error GoTo ExitCallBack
....
   
ExitCallBack:
    
    If Err.Number > 0 Then
        ExlUnfreeze
        Output "Ошибка в работе макроса.", vbCritical
    Else
        ExlUnfreeze
    End If
    
    On Error GoTo 0

Ходы конем:
1. Почему не получается сделать два отчета друг под другом с существенным запасом пустых строк и пустые строки скрывать?
2. Почему не получается приклеивать второй отчет к первому, а нужно именно слияние в сторонке?

bream

На счет последнего вызова, Я проверял:
Последовательность вызова определяется номером грид, самым последним вызывается 1й грид.
Если в книге 3 инфопровайдера, и два грида, то макрос отработает два раза. Последовательность описана выше.

G

bream написал(а):

На счет последнего вызова, Я проверял:
Последовательность вызова определяется номером грид, самым последним вызывается 1й грид.
Если в книге 3 инфопровайдера, и два грида, то макрос отработает два раза. Последовательность описана выше.

Спасибо, информация ценная.
Тогда ход конем № 2 становится самым простым решением, если не требуется преобразования данных

vtb

G написал:

Мои 5 копеек. Как бы сделал я:
1. Создал бы два именованных диапазона на листе, где сливаются отчеты.
2. Можно даже смело назвать именованные диапазоны как провайдеры в книге DP_1 и DP_2
3. В колбеке я бы очищал диапазон соответствующий провайдеру от данных, потом добавлял или удалял из него строки до количества строк в отчете.
4. После приведения количества строк в соответствие -- область заполнить данными.

Критика предложенных решений:

1. Все предложенные решения оперируют несуществующим понятием "последний вызов". На практике последний вызов совершается для первого добавленного в книгу отчета. Но все равно стремный вариант. Непонятно зачем на это опираться.

2. Внутренние массивы неприятны тем, что форматирование придется создавать руками, а не копировать из готовых и отформатированных Bex-отчетов, и если есть валюта и единица измерения, вообще все кодоемко будет.

3. Избавьтесь от такой конструкции:

Code:

Set destws = ThisWorkbook.Worksheets("Итоговый лист")

Привязывайтесь к листу любыми другими способами.

4. Для отрубания реакций экселя используйте только конструкцию с обработкой ошибок, иначе эксель будет "подвисать":

Code:

Sub Output(ByVal Text As String, ByVal Level As Integer)
       
..........................................

Ходы конем:
1. Почему не получается сделать два отчета друг под другом с существенным запасом пустых строк и пустые строки скрывать?
2. Почему не получается приклеивать второй отчет к первому, а нужно именно слияние?

большое спасибо!

насчет ходов конем:
1 - потому что количество строк в верхней таблице будет все время разное.
2 - не очень понял. нужно именно приклеивать, но на отдельном листе.

G

vtb написал:

1. не получается - потому что количество строк в верхней таблице будет все время разное.

Поэтому и предлагается сделать, например, 10 000 пустых строк.
И сделать их высоту нулевую. И в колбеке смотреть какие скрыть, а какие показать. И никаких грязных манипуляций данными

vtb написал:

2 - не очень понял. нужно именно приклеивать, но на отдельном листе.

Имеется ввиду, что пользователь смотрит на лист где есть грид с первым отчетом, к которому снизу макросом дописаны данные второго отчета.
Зачем дополнительный лист?

ash

Итак, подискутируем.

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

Метод с пустыми скрытыми строками не всегда применим - например, он не подходит в случаях, когда пользователь копирует руками результат отчета в какие-либо свои свои файлы и при всставке увидит всю массу скрытых строк.

G

Замонали.

Есть 4 области:
data_t - отчет, который нужно поставить сверху, в реальном примере не нужен.
data_b - отчет, который нужно поставить снизу, в реальном примере не нужен.
top_area - область, куда помещать верхний отчет
bottom_area - область, куда помещать нижний отчет

Code:

'Sub Callback(ParamArray varname())
Sub Callback(Nm As String)
    Dim QueryRange As Range
    Dim AreaRange As Range
    Dim Area As String
    Set QueryRange = ThisWorkbook.Names(Nm).RefersToRange
'    Set QueryRange = varname(1)
    
    Select Case Nm ' varname(0) 
        Case "data_t" ' "DP_1"
            Area = "top_area"
        Case "data_b" ' "DP_2"
           Area = "bottom_area" 
        Case Else
            Exit Sub   
    End Select
            
    Set AreaRange = ThisWorkbook.Names(Area).RefersToRange
    AreaRange.ClearContents
    AreaRange.ClearFormats

    Do While AreaRange.Rows.Count < QueryRange.Rows.Count
        AreaRange.Rows(1).Insert (xlShiftDown)
        Range(AreaRange.Offset(-1, 0), AreaRange.Cells(AreaRange.Rows.Count, AreaRange.Columns.Count)).Name = Area
        Set AreaRange = ThisWorkbook.Names(Area).RefersToRange
    Loop

    Do While AreaRange.Rows.Count > QueryRange.Rows.Count
        AreaRange.Rows(1).Delete (xlShiftUp)
    Loop
    
    QueryRange.Copy (AreaRange.Cells(1, 1))
    
End Sub


Sub TST()
    Callback ("data_b")
    Callback ("data_t")
End Sub

Если надо выслать тестовую книжку, скажите емыл.

PS. От циклов можно избавиться, если отчеты большие.

Макрос для копирования и совмещения динамических таблиц

Кто сейчас на конференции