Здравствуйте Просьба помочь в реализации вопроса копирования последней строки с информацией со всех листов в один посредством уже разработанного способа через VBA, а именно копированием лишь последних строк.
В статье есть примеры на выбор какие диапазоны копировать (18-21 строки кода, второго способа) а необходимо скопировать только последние строки с информацией.
В силу редких случаев использования макросов пытался в строке
Код
Set rngData = ws.Range("A2", ws.Range("A2").SpecialCells(xlCellTypeLastCell))
вместо "А2" указывать переменную n т.к. она выше в коде описывает номер последней строки и Cells(n + 1, 1) - не удалось
Просьба подсказать, если возможно, какой код указать для копирования последних строк с информацией со всех листов в книге с помощью макроса, который описан в вышеупомянутой статье
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Файл примера добавил. На данный момент макрос выполняет копирование в новую книгу всей информации, а необходимо только строку итогов с каждого листа. Советы выше, к сожалению, не помогли
DEHNC1, если у вас умные таблицы, то можно не вычислять последнюю строку, а копировать итоги напрямую (это часть объекта-таблицы)
Код (создаст новый лист и скопирует итоги на него)
Код
Option Explicit
'====================================================================================================
Sub CollectDataFromAllSheets()
Dim shTotal As Worksheet, sh As Worksheet
Dim r&
Application.ScreenUpdating = False
Worksheets.Add
Set shTotal = ActiveSheet
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> shTotal.Name And sh.ListObjects.Count = 1 Then
r = r + 1
sh.ListObjects(1).TotalsRowRange.Copy
shTotal.Cells(r, 1).PasteSpecial Paste:=xlPasteValues
End If
Next sh
Application.CutCopyMode = False
shTotal.Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
'====================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Копирует итоги с умных таблиц на новый лист. Берёт шапку из первой подходящей таблицы
Код
Код
Option Explicit
'====================================================================================================
Sub CollectDataFromAllSheets()
Dim shTotal As Worksheet, sh As Worksheet
Dim r&, flag As Boolean
Application.ScreenUpdating = False
Worksheets.Add
Set shTotal = ActiveSheet
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> shTotal.Name And sh.ListObjects.Count = 1 Then
If Not flag Then
flag = True: r = r + 1
sh.ListObjects(1).HeaderRowRange.Copy
shTotal.Cells(r, 1).PasteSpecial Paste:=xlPasteValues
End If
r = r + 1
sh.ListObjects(1).TotalsRowRange.Copy
shTotal.Cells(r, 1).PasteSpecial Paste:=xlPasteValues
End If
Next sh
Application.CutCopyMode = False
shTotal.Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
'====================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄