Совсем без макроса не получилось, ибо если делать формулами, то нужно постоянно следить за количеством строк в таблицах и протягивать формулы, что никак не вяжется с
все ненулевые (ошибки тоже распознаются как 0) строки из таблиц с листа Лист1 собираются подключением (Данные>подключения) в таблицу на листе Лист2 Таблица обновляется так же, как и сводная (ПКМ>Обновить) сделал макрос для обновления параметров подключения и автообновления таблицы в модуле Лист2[vba]
Код
Public WithEvents QTbl As QueryTable Private Sub QTbl_BeforeRefresh(Cancel As Boolean) Dim arr() As Variant, i&, strSQL$, LO As ListObject For Each LO In Sheets("Лист1").ListObjects i = i + 1 ReDim Preserve arr(i) arr(i) = LO.Range.Address(0, 0, 1, 1) Next With Application arr = .Substitute(.ReplaceB(arr, 1, Len(ThisWorkbook.Name) + 2, ""), "!", "$") End With strSQL = "select * from (" & Mid(Join(arr, "] union all select * from ["), 13) & "]) where Сумма" QTbl.Connection = "ODBC;DSN=Excel Files;DriverId=1046;DBQ=" & Parent.FullName QTbl.CommandText = strSQL End Sub Private Sub Worksheet_Activate() Init QTbl.Refresh End Sub
[/vba]в модуле ЭтаКнига [vba]
Код
Private Sub Workbook_Open() Call Init End Sub
[/vba]в стандартном модуле[vba]
Код
Public tbl As QueryTable Sub Init() If tbl Is Nothing Then Set Лист2.QTbl = Лист2.ListObjects(1).QueryTable Set tbl = Лист2.QTbl End Sub
[/vba]
Совсем без макроса не получилось, ибо если делать формулами, то нужно постоянно следить за количеством строк в таблицах и протягивать формулы, что никак не вяжется с
все ненулевые (ошибки тоже распознаются как 0) строки из таблиц с листа Лист1 собираются подключением (Данные>подключения) в таблицу на листе Лист2 Таблица обновляется так же, как и сводная (ПКМ>Обновить) сделал макрос для обновления параметров подключения и автообновления таблицы в модуле Лист2[vba]
Код
Public WithEvents QTbl As QueryTable Private Sub QTbl_BeforeRefresh(Cancel As Boolean) Dim arr() As Variant, i&, strSQL$, LO As ListObject For Each LO In Sheets("Лист1").ListObjects i = i + 1 ReDim Preserve arr(i) arr(i) = LO.Range.Address(0, 0, 1, 1) Next With Application arr = .Substitute(.ReplaceB(arr, 1, Len(ThisWorkbook.Name) + 2, ""), "!", "$") End With strSQL = "select * from (" & Mid(Join(arr, "] union all select * from ["), 13) & "]) where Сумма" QTbl.Connection = "ODBC;DSN=Excel Files;DriverId=1046;DBQ=" & Parent.FullName QTbl.CommandText = strSQL End Sub Private Sub Worksheet_Activate() Init QTbl.Refresh End Sub
[/vba]в модуле ЭтаКнига [vba]
Код
Private Sub Workbook_Open() Call Init End Sub
[/vba]в стандартном модуле[vba]
Код
Public tbl As QueryTable Sub Init() If tbl Is Nothing Then Set Лист2.QTbl = Лист2.ListObjects(1).QueryTable Set tbl = Лист2.QTbl End Sub
Function Unescape$(uStr$) With CreateObject("scriptcontrol") .Language = "JScript" Unescape = .Eval("unescape(""" & uStr & """)") End With End Function
[/vba] и, на всякий случай, с помощью того же scriptcontrol можно парсить json, например вот UPD. Исправил косяк в коде
а у мну вот такая функция есть [vba]
Код
Function Unescape$(uStr$) With CreateObject("scriptcontrol") .Language = "JScript" Unescape = .Eval("unescape(""" & uStr & """)") End With End Function
[/vba] и, на всякий случай, с помощью того же scriptcontrol можно парсить json, например вот UPD. Исправил косяк в кодеkrosav4ig
SELECT t1.*, [Receiving], [Putaway], IIF( [Receiving] IS NULL, IIF( [Putaway] IS NULL, NULL, [Putaway] ), IIF( [Putaway] IS NULL, [Receiving], [Receiving]+[Putaway] ) ) AS [Total receiving & putaway] FROM [Список смен] t1 INNER JOIN ( SELECT [Логин], SUM([Принято линий]) AS Receiving, SUM([Размещено линий]) AS Putaway FROM ( SELECT [Год], [Месяц], ( SELECT FIRST( IIF( [Логин] IS NULL, [Логин SAP], [Логин] ) ) FROM [Список смен] WHERE [Логин]=t1.[Логин] OR [Логин SAP]=t1.[Логин] ) AS [Логин], [Принято линий], NULL AS [Размещено линий] FROM [\\RU-TRF4490X21\BASE\TOTAL\Total Activity.accdb].tb_inb_stat t1 UNION ALL SELECT [Год], [Месяц], ( SELECT FIRST( IIF( [Логин] IS NULL, [Логин SAP], [Логин] ) ) FROM [Список смен] WHERE [Логин]=t2.[Логин] OR [Логин SAP]=t2.[Логин] ) AS [Логин], NULL, [Размещено линий] FROM [\\RU-TRF4490X21\BASE\TOTAL\Total Activity.accdb].tb_razm_stat t2 ) t1 WHERE t1.[Год]=? and t1.[Месяц]=? GROUP BY t1.[Год], t1.[Месяц], t1.[Логин] ) t2 ON t1.[Логин SAP] = t2.[Логин] OR t1.[Логин] = t2.[Логин]
[/vba]
До кучи SQL запрос с параметрами (через MSQuery)
[vba]
Код
SELECT t1.*, [Receiving], [Putaway], IIF( [Receiving] IS NULL, IIF( [Putaway] IS NULL, NULL, [Putaway] ), IIF( [Putaway] IS NULL, [Receiving], [Receiving]+[Putaway] ) ) AS [Total receiving & putaway] FROM [Список смен] t1 INNER JOIN ( SELECT [Логин], SUM([Принято линий]) AS Receiving, SUM([Размещено линий]) AS Putaway FROM ( SELECT [Год], [Месяц], ( SELECT FIRST( IIF( [Логин] IS NULL, [Логин SAP], [Логин] ) ) FROM [Список смен] WHERE [Логин]=t1.[Логин] OR [Логин SAP]=t1.[Логин] ) AS [Логин], [Принято линий], NULL AS [Размещено линий] FROM [\\RU-TRF4490X21\BASE\TOTAL\Total Activity.accdb].tb_inb_stat t1 UNION ALL SELECT [Год], [Месяц], ( SELECT FIRST( IIF( [Логин] IS NULL, [Логин SAP], [Логин] ) ) FROM [Список смен] WHERE [Логин]=t2.[Логин] OR [Логин SAP]=t2.[Логин] ) AS [Логин], NULL, [Размещено линий] FROM [\\RU-TRF4490X21\BASE\TOTAL\Total Activity.accdb].tb_razm_stat t2 ) t1 WHERE t1.[Год]=? and t1.[Месяц]=? GROUP BY t1.[Год], t1.[Месяц], t1.[Логин] ) t2 ON t1.[Логин SAP] = t2.[Логин] OR t1.[Логин] = t2.[Логин]
Sub dd() Dim cell(3) As Range, sel(1) As Object, sh As Worksheet, shts As Sheets, I, r As Range, l, t Application.EnableEvents = 0 With ThisWorkbook.Windows(1) Set shts = .SelectedSheets: Set sh = ActiveSheet: Set cell(0) = .VisibleRange(1, 1) Set sel(0) = Selection: Set cell(1) = ActiveCell Set r = [Лист2!A4]: r.Parent.Select Set cell(2) = .VisibleRange(1, 1): Set cell(3) = ActiveCell Set sel(1) = Selection Application.Goto r, 1 For I = 1 To .Panes.Count If Not Intersect(r, .Panes(I).VisibleRange) Is Nothing Then With .Panes(I) Dim pic l = .PointsToScreenPixelsX(r.Left) + 1 t = .PointsToScreenPixelsY(r.Top) + 1 AppActivate (Application.Caption) DoEvents Set pic = ActiveWindow.RangeFromPoint(l, t) Debug.Print pic.Name Stop End With End If Next Application.Goto cell(2): sel(1).Select: cell(3).Activate shts.Select: sh.Activate: Application.Goto cell(0), 1: sel(0).Select: cell(1).Activate Erase cell, sel: Set sh = Nothing: Set shts = Nothing: Set r = Nothing End With Application.EnableEvents = 1 End Sub
[/vba]
Танцы с бубном заказывали? [vba]
Код
Sub dd() Dim cell(3) As Range, sel(1) As Object, sh As Worksheet, shts As Sheets, I, r As Range, l, t Application.EnableEvents = 0 With ThisWorkbook.Windows(1) Set shts = .SelectedSheets: Set sh = ActiveSheet: Set cell(0) = .VisibleRange(1, 1) Set sel(0) = Selection: Set cell(1) = ActiveCell Set r = [Лист2!A4]: r.Parent.Select Set cell(2) = .VisibleRange(1, 1): Set cell(3) = ActiveCell Set sel(1) = Selection Application.Goto r, 1 For I = 1 To .Panes.Count If Not Intersect(r, .Panes(I).VisibleRange) Is Nothing Then With .Panes(I) Dim pic l = .PointsToScreenPixelsX(r.Left) + 1 t = .PointsToScreenPixelsY(r.Top) + 1 AppActivate (Application.Caption) DoEvents Set pic = ActiveWindow.RangeFromPoint(l, t) Debug.Print pic.Name Stop End With End If Next Application.Goto cell(2): sel(1).Select: cell(3).Activate shts.Select: sh.Activate: Application.Goto cell(0), 1: sel(0).Select: cell(1).Activate Erase cell, sel: Set sh = Nothing: Set shts = Nothing: Set r = Nothing End With Application.EnableEvents = 1 End Sub
Sub d() Dim r As Range With [index(2!A:A,rows(A:A))].End(xlUp) Set r = IIf(.Row > 4, .Offset(1), [2!A4]) End With [1!A:A].Replace "s", "=zz1", 1 On Error Resume Next With [1!ZZ1].Dependents .Value = "s" .EntireRow.Copy r .EntireRow.Delete End With End Sub
[/vba]
или так[vba]
Код
Sub d() Dim r As Range With [index(2!A:A,rows(A:A))].End(xlUp) Set r = IIf(.Row > 4, .Offset(1), [2!A4]) End With [1!A:A].Replace "s", "=zz1", 1 On Error Resume Next With [1!ZZ1].Dependents .Value = "s" .EntireRow.Copy r .EntireRow.Delete End With End Sub
Дополнение к материалу по ссылке Делаем из диапазона умную таблицу, при добавлении диапазонов в консолидированную сводную в мастере сводных и диаграмм пишем не адрес диапазона, а ссылку на таблицу в формате ИмяТаблицы[#Все] и отпадает необходимость следить за изменением размеров исходных диапазонов изменить/добавить диапазоны в консолидированной сводной можно выделив любой элемент в сводной и нажав иконку мастера сводных и диаграмм, затем тык по кнопке Назад
Дополнение к материалу по ссылке Делаем из диапазона умную таблицу, при добавлении диапазонов в консолидированную сводную в мастере сводных и диаграмм пишем не адрес диапазона, а ссылку на таблицу в формате ИмяТаблицы[#Все] и отпадает необходимость следить за изменением размеров исходных диапазонов изменить/добавить диапазоны в консолидированной сводной можно выделив любой элемент в сводной и нажав иконку мастера сводных и диаграмм, затем тык по кнопке Назадkrosav4ig
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
