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
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.[Логин]
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
Совсем без макроса не получилось, ибо если делать формулами, то нужно постоянно следить за количеством строк в таблицах и протягивать формулы, что никак не вяжется с
все ненулевые (ошибки тоже распознаются как 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
Sub ChangeProps() Dim note$: note = "АБВГ" Dim FIO$: FIO = "Иванов" With CreateObject("DSOFile.OleDocumentProperties") .Open "D:\Шаблон.dwt", , 2 With .CustomProperties On Error Resume Next .Add "ФИО", FIO .Add "Обозначение", note Err.Clear: On Error GoTo 0 .Item("ФИО") = FIO .Item("Обозначение") = note End With .Save: .Close End With End Sub
[/vba] для работы нужно скачать и установить DSOfile
Здравствуйте Как-то так можно [vba]
Код
Sub ChangeProps() Dim note$: note = "АБВГ" Dim FIO$: FIO = "Иванов" With CreateObject("DSOFile.OleDocumentProperties") .Open "D:\Шаблон.dwt", , 2 With .CustomProperties On Error Resume Next .Add "ФИО", FIO .Add "Обозначение", note Err.Clear: On Error GoTo 0 .Item("ФИО") = FIO .Item("Обозначение") = note End With .Save: .Close End With End Sub
Sub test() Dim shtX As Worksheet Dim rngNew As Range Dim rngOld As Range
Set shtX = ThisWorkbook.Worksheets(1) Set rngNew = shtX.Range("vNew") Set rngOld = shtX.Range("vOld")
If UBound(Filter(Application.CountIf(rngNew, rngOld.Value), 0)) = -1 Then MsgBox "значения совпадают" 'если все значения массива совпадают Else MsgBox "значения различаются" 'если хотя бы одно не совпадает End If
End Sub
[/vba]
еще вариант
[vba]
Код
Sub test() Dim shtX As Worksheet Dim rngNew As Range Dim rngOld As Range
Set shtX = ThisWorkbook.Worksheets(1) Set rngNew = shtX.Range("vNew") Set rngOld = shtX.Range("vOld")
If UBound(Filter(Application.CountIf(rngNew, rngOld.Value), 0)) = -1 Then MsgBox "значения совпадают" 'если все значения массива совпадают Else MsgBox "значения различаются" 'если хотя бы одно не совпадает End If
kollega, имхо, в у вас файле не совсем правильный подсчет количества вариантов. формулы вычисления количества и генерации комбинаций были спёрты отсюда
kollega, имхо, в у вас файле не совсем правильный подсчет количества вариантов. формулы вычисления количества и генерации комбинаций были спёрты отсюдаkrosav4ig
Это я немного ступил, не из той оперы. Нету Nil в vba, там должен быть "" или vbnullstring или empty. А нужно это для того, чтобы перед единицей тоже вставился разделитель [vba]
Код
"," & s
[/vba], а [vba]
Код
mid(join( ... , ...),2)
[/vba] нужно чтобы убрать лишнюю запятую в начале И есть еще один нюанс. Если при объявлении строковой переменной задана длина, то компилятор по дефолту присваивает этой переменной значение [vba]
Код
String(n," ")
[/vba],т.е. строка, состоящая из n пробелов, где n = объявленная длина. Поэтому вместо [vba]
Это я немного ступил, не из той оперы. Нету Nil в vba, там должен быть "" или vbnullstring или empty. А нужно это для того, чтобы перед единицей тоже вставился разделитель [vba]
Код
"," & s
[/vba], а [vba]
Код
mid(join( ... , ...),2)
[/vba] нужно чтобы убрать лишнюю запятую в начале И есть еще один нюанс. Если при объявлении строковой переменной задана длина, то компилятор по дефолту присваивает этой переменной значение [vba]
Код
String(n," ")
[/vba],т.е. строка, состоящая из n пробелов, где n = объявленная длина. Поэтому вместо [vba]
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
