Ну дык в классе Workbooks нету свойства Cells, о чем и говорит ошибка 438 "Object doesn't support this property or method" - "Объект не поддерживает данное свойство или метод" Вы про лист забыли. И про точку перед Rows не стоит забывать во избежание возможных ошибок. [vba]
Код
Set Wb = Workbooks("BASA.xls") with Wb.Sheets("SheetName") Temp = .Cells(.Rows.Count, 1).End(xlUp).Row end with
[/vba]
Ну дык в классе Workbooks нету свойства Cells, о чем и говорит ошибка 438 "Object doesn't support this property or method" - "Объект не поддерживает данное свойство или метод" Вы про лист забыли. И про точку перед Rows не стоит забывать во избежание возможных ошибок. [vba]
Код
Set Wb = Workbooks("BASA.xls") with Wb.Sheets("SheetName") Temp = .Cells(.Rows.Count, 1).End(xlUp).Row end with
До официального выхода Office 2019, который планируется во втором полугодии 2018 года, весь материал, изложенный ниже, предоставляется исключительно для ознакомления. Все действия пользователи производят на свой страх и риск.
На прошлогоднем семинаре Ignite мы объявили о выпуске Office 2019 — новой версии набора Office с бессрочной лицензией, в состав которого войдут приложения (в том числе Word, Excel, PowerPoint, Outlook и Skype для бизнеса) и серверы (включая Exchange, SharePoint и Skype для бизнеса). Сегодня мы рады поделиться с вами следующими новостями.
Выпуск Office 2019 планируется во втором полугодии 2018 года. Предварительные версии новых приложений и серверов можно будет получить уже во втором квартале 2018 года.
Приложения Office 2019 будут поддерживаться в следующих системах:
все поддерживаемые выпуски Windows 10 SAC;
Windows 10 Корпоративная LTSC 2018;
следующий выпуск Windows Server LTSC.
Клиентские приложения Office 2019 будут поддерживать только технологию «нажми и работай», мы не будем предоставлять для них методологию развертывания с помощью MSI. Мы по-прежнему будем поддерживать MSI для серверных продуктов Office.
Современное программное обеспечение предоставляет не только новые функции, которые помогают сотрудникам работать максимально продуктивно, но и новые, более эффективные решения для управления и более комплексный подход к безопасности. Если программное обеспечение было создано более десяти лет назад и не обновлялось, обеспечить его безопасность становится сложно. К тому же оно неизбежно уступает современным программам в производительности. Изменения ускоряются, и мы пришли к выводу о необходимости перевести программное обеспечение на более современный цикл обновления. Раньше новые версии Office с бессрочной лицензией выпускались на условиях фиксированной политики жизненного цикла поддержки продуктов Майкрософт, которая предусматривала 5 лет основной поддержки и 5 лет расширенной поддержки. Office 2019 будет поставляться на следующих особых условиях с сокращенным периодом расширенной поддержки.
Office 2019 будет предусматривать 5 лет основной и около 2 лет расширенной поддержки. Это исключение из нашей фиксированной политики жизненного цикла поддержки позволит скоординировать поддержку нового набора и Office 2016. Расширенная поддержка завершится 14 октября 2025 г. Сроки поддержки существующих версий Office меняться не будут.
Для удаления лицензий и ключей от ранее установленных версий оффиса применяем утилиту от Ratiborus http://forum.ru-board.com/topic.cgi?forum=2&bm=1&topic=5693#1 Office 2013-2016 C2R License Setup v1.0X TEST.7z После запуска жмём "Refresh", галочками будут отмечены все лицензии оффиса, установленные в системе. Будет что-то типа Снимаем все "галки", отмечаем "Delete all keys" и жмём "Setup". Проверяем в Командной строке от Администратора [vba]
[/vba] Должно получиться вот так Для особо "тяжелых" случаев применяем команды или вручную удаляем файлы
на инсайдеских сборках [vba]
Код
net stop sppsvc del %windir%\System32\spp\store_test\2.0\tokens.dat del %windir%\System32\spp\store_test\2.0\data.dat del %windir%\System32\spp\store_test\2.0\cache\cache.dat net start sppsvc
[/vba]
на стабильных [vba]
Код
net stop sppsvc del %windir%\System32\spp\store\2.0\tokens.dat del %windir%\System32\spp\store\2.0\data.dat del %windir%\System32\spp\store\2.0\cache\cache.dat net start sppsvc
[/vba] После этого начинаем установку оффиса.
Установка Скачивание и установка с помощью установщика от Ratiborus
1. Перед установкой обязательно удалить любой установленный оффис и подчистить "хвосты"утилиты по удалению от M$ для разных версий https://answers.microsoft.com/ru-ru....2fab48d 2. Установка онлайн Выбираем компоненты, разрядность, язык, которые хотим установить и жмём install office далее ОК, всё, установка пошла По умолчанию, загрузка идёт с канала Production::LTSC F2E724C1-748F-4B47-8FB8-8E0D210E9208 3. Скачать и сделать ISO для автономной установки вкладка download office-custom branch-download указываем место для сохранения начинается загрузка бранчей (каналов скачивания и обновления), ждём пока загрузятся все, выбираем тот, который нравится, рекомендую Production::LTSC F2E724C1-748F-4B47-8FB8-8E0D210E9208 для установки Preview версии 5440FD1F-7ECB-4221-8110-145EFAA6372F жмём continue, начинается скачивание После скачивания Creat ISO. Для установки с ISO действуем аналогично п.2, только установка будет происходить с образа (можно отключить интернет). Всё, как-то так.
Скачивание и установка вручную с помощью Office 2016 Deployment Tool
Скачиваем Office 2016 Deployment Tool Ссылка Распаковываем в любую папку (главное все последующие манипуляции производить в одной папке). EULA удаляем, шоб не мешалась. Открываем (можно блокнотом) configuration.xml и корректирум под наши запросы: Стандартный файл кофигурации для онлайн установки Office2019 ProPlus + Project + Visio выглядит так:
[vba]
Код
<Configuration> <Add OfficeClientEdition="32"> (или "64", в зависимости от разрядности) <Product ID="ProPlus2019Retail"> <Language ID="ru-ru" /> </Product> <Product ID="VisioPro2019Retail"> <Language ID="ru-ru" /> </Product> <Product ID="ProjectPro2019Retail"> <Language ID="ru-ru" /> </Product> </Add> </Configuration>
[/vba] Чтобы исключить из пакета ненужные приложения, используем команды
[/vba] Для удаления OneDrive для бизнеса используем значение Groove, для удаления Skype для бизнеса - Lync. Например, чтобы установить русский Office2019 ProPlus х32 только с Word, Exel, PowerPoint с конкретного канала/бранча применяем
До официального выхода Office 2019, который планируется во втором полугодии 2018 года, весь материал, изложенный ниже, предоставляется исключительно для ознакомления. Все действия пользователи производят на свой страх и риск.
На прошлогоднем семинаре Ignite мы объявили о выпуске Office 2019 — новой версии набора Office с бессрочной лицензией, в состав которого войдут приложения (в том числе Word, Excel, PowerPoint, Outlook и Skype для бизнеса) и серверы (включая Exchange, SharePoint и Skype для бизнеса). Сегодня мы рады поделиться с вами следующими новостями.
Выпуск Office 2019 планируется во втором полугодии 2018 года. Предварительные версии новых приложений и серверов можно будет получить уже во втором квартале 2018 года.
Приложения Office 2019 будут поддерживаться в следующих системах:
все поддерживаемые выпуски Windows 10 SAC;
Windows 10 Корпоративная LTSC 2018;
следующий выпуск Windows Server LTSC.
Клиентские приложения Office 2019 будут поддерживать только технологию «нажми и работай», мы не будем предоставлять для них методологию развертывания с помощью MSI. Мы по-прежнему будем поддерживать MSI для серверных продуктов Office.
Современное программное обеспечение предоставляет не только новые функции, которые помогают сотрудникам работать максимально продуктивно, но и новые, более эффективные решения для управления и более комплексный подход к безопасности. Если программное обеспечение было создано более десяти лет назад и не обновлялось, обеспечить его безопасность становится сложно. К тому же оно неизбежно уступает современным программам в производительности. Изменения ускоряются, и мы пришли к выводу о необходимости перевести программное обеспечение на более современный цикл обновления. Раньше новые версии Office с бессрочной лицензией выпускались на условиях фиксированной политики жизненного цикла поддержки продуктов Майкрософт, которая предусматривала 5 лет основной поддержки и 5 лет расширенной поддержки. Office 2019 будет поставляться на следующих особых условиях с сокращенным периодом расширенной поддержки.
Office 2019 будет предусматривать 5 лет основной и около 2 лет расширенной поддержки. Это исключение из нашей фиксированной политики жизненного цикла поддержки позволит скоординировать поддержку нового набора и Office 2016. Расширенная поддержка завершится 14 октября 2025 г. Сроки поддержки существующих версий Office меняться не будут.
Для удаления лицензий и ключей от ранее установленных версий оффиса применяем утилиту от Ratiborus http://forum.ru-board.com/topic.cgi?forum=2&bm=1&topic=5693#1 Office 2013-2016 C2R License Setup v1.0X TEST.7z После запуска жмём "Refresh", галочками будут отмечены все лицензии оффиса, установленные в системе. Будет что-то типа Снимаем все "галки", отмечаем "Delete all keys" и жмём "Setup". Проверяем в Командной строке от Администратора [vba]
[/vba] Должно получиться вот так Для особо "тяжелых" случаев применяем команды или вручную удаляем файлы
на инсайдеских сборках [vba]
Код
net stop sppsvc del %windir%\System32\spp\store_test\2.0\tokens.dat del %windir%\System32\spp\store_test\2.0\data.dat del %windir%\System32\spp\store_test\2.0\cache\cache.dat net start sppsvc
[/vba]
на стабильных [vba]
Код
net stop sppsvc del %windir%\System32\spp\store\2.0\tokens.dat del %windir%\System32\spp\store\2.0\data.dat del %windir%\System32\spp\store\2.0\cache\cache.dat net start sppsvc
[/vba] После этого начинаем установку оффиса.
Установка Скачивание и установка с помощью установщика от Ratiborus
1. Перед установкой обязательно удалить любой установленный оффис и подчистить "хвосты"утилиты по удалению от M$ для разных версий https://answers.microsoft.com/ru-ru....2fab48d 2. Установка онлайн Выбираем компоненты, разрядность, язык, которые хотим установить и жмём install office далее ОК, всё, установка пошла По умолчанию, загрузка идёт с канала Production::LTSC F2E724C1-748F-4B47-8FB8-8E0D210E9208 3. Скачать и сделать ISO для автономной установки вкладка download office-custom branch-download указываем место для сохранения начинается загрузка бранчей (каналов скачивания и обновления), ждём пока загрузятся все, выбираем тот, который нравится, рекомендую Production::LTSC F2E724C1-748F-4B47-8FB8-8E0D210E9208 для установки Preview версии 5440FD1F-7ECB-4221-8110-145EFAA6372F жмём continue, начинается скачивание После скачивания Creat ISO. Для установки с ISO действуем аналогично п.2, только установка будет происходить с образа (можно отключить интернет). Всё, как-то так.
Скачивание и установка вручную с помощью Office 2016 Deployment Tool
Скачиваем Office 2016 Deployment Tool Ссылка Распаковываем в любую папку (главное все последующие манипуляции производить в одной папке). EULA удаляем, шоб не мешалась. Открываем (можно блокнотом) configuration.xml и корректирум под наши запросы: Стандартный файл кофигурации для онлайн установки Office2019 ProPlus + Project + Visio выглядит так:
[vba]
Код
<Configuration> <Add OfficeClientEdition="32"> (или "64", в зависимости от разрядности) <Product ID="ProPlus2019Retail"> <Language ID="ru-ru" /> </Product> <Product ID="VisioPro2019Retail"> <Language ID="ru-ru" /> </Product> <Product ID="ProjectPro2019Retail"> <Language ID="ru-ru" /> </Product> </Add> </Configuration>
[/vba] Чтобы исключить из пакета ненужные приложения, используем команды
[/vba] Для удаления OneDrive для бизнеса используем значение Groove, для удаления Skype для бизнеса - Lync. Например, чтобы установить русский Office2019 ProPlus х32 только с Word, Exel, PowerPoint с конкретного канала/бранча применяем
Видимо, подразумевается, что файлов несколько, и их нужно впихнуть в один массив
[vba]
Код
Sub DBF() Const sTempFileName = "123456.dbf" Dim p$, f$, t$, c$, sFileName$, arr As Variant With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Выбрать папку": .Show If .SelectedItems.Count = 0 Then Exit Sub Else p = .SelectedItems(1) & "\" End If End With f = Dir(p & "*.dbf") t = "tmp.dbf" sFileName = p + f FileCopy sFileName, p + t c = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & p & ";Extended Properties=dBASE IV" With CreateObject("ADODB.Recordset") .Open "delete * from tmp", c Do While f <> "" If f <> t Then Name sFileName As p + sTempFileName .Open "insert into tmp select * from 123456", c Name p + sTempFileName As sFileName End If f = Dir$() Loop .Open "select * from tmp", c arr = .getrows .Close .Open "drop table tmp", c End With End Sub
[/vba]
Видимо, подразумевается, что файлов несколько, и их нужно впихнуть в один массив
[vba]
Код
Sub DBF() Const sTempFileName = "123456.dbf" Dim p$, f$, t$, c$, sFileName$, arr As Variant With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Выбрать папку": .Show If .SelectedItems.Count = 0 Then Exit Sub Else p = .SelectedItems(1) & "\" End If End With f = Dir(p & "*.dbf") t = "tmp.dbf" sFileName = p + f FileCopy sFileName, p + t c = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & p & ";Extended Properties=dBASE IV" With CreateObject("ADODB.Recordset") .Open "delete * from tmp", c Do While f <> "" If f <> t Then Name sFileName As p + sTempFileName .Open "insert into tmp select * from 123456", c Name p + sTempFileName As sFileName End If f = Dir$() Loop .Open "select * from tmp", c arr = .getrows .Close .Open "drop table tmp", c End With End Sub
dd() With ActiveSheet.UsedRange With Intersect(.SpecialCells(xlCellTypeConstants, 23).EntireRow, .Columns) .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C1" End With .Formula = .Value .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete .Cut [A1] End With End Sub
[/vba]
до кучи Sub [vba]
Код
dd() With ActiveSheet.UsedRange With Intersect(.SpecialCells(xlCellTypeConstants, 23).EntireRow, .Columns) .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C1" End With .Formula = .Value .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete .Cut [A1] End With End Sub
Sheets("Лист2").Select lr = Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row lr2 = Sheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To lr2 On Error Resume Next V = Sheets("Лист2").Cells(i, 1).Value m = Application.WorksheetFunction.VLookup(V, Sheets("Лист1").Range("A1:B" & lr2), 2, False)
If Not IsEmpty(m) Then Cells(i, 2).Value = Cells(i, 2).Value - m
Next i
End Sub
[/vba] и еще вариант до кучи [vba]
Код
Sub ss() Dim i&, m As Variant With Sheets("Лист2") For Each v In .[A1].CurrentRegion.Columns(1).Value i = i + 1 m = Application.VLookup(v, Sheets("Лист1").[A1].CurrentRegion, 2, False) With .Cells(i, 2) If Not IsEmpty(m) Then .Value = .Value - m End With Next End With End Sub
[/vba]
Как-то так
Нужно условие добавить [vba]
Код
Sub ss()
Sheets("Лист2").Select lr = Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row lr2 = Sheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To lr2 On Error Resume Next V = Sheets("Лист2").Cells(i, 1).Value m = Application.WorksheetFunction.VLookup(V, Sheets("Лист1").Range("A1:B" & lr2), 2, False)
If Not IsEmpty(m) Then Cells(i, 2).Value = Cells(i, 2).Value - m
Next i
End Sub
[/vba] и еще вариант до кучи [vba]
Код
Sub ss() Dim i&, m As Variant With Sheets("Лист2") For Each v In .[A1].CurrentRegion.Columns(1).Value i = i + 1 m = Application.VLookup(v, Sheets("Лист1").[A1].CurrentRegion, 2, False) With .Cells(i, 2) If Not IsEmpty(m) Then .Value = .Value - m End With Next End With End Sub
Sub sdf() Dim Dic As Object Dim sh As Worksheet Dim r As Range, w As Range, c As Range Dim arr() As Variant, arr1 As Variant Dim i, j, k, l, m, n, o
Set Dic = CreateObject("scripting.dictionary") For Each w In Sheets("Criteria").Cells.SpecialCells(xlCellTypeConstants, 1).Areas With w.Offset(-1, -1).Resize(1, 1) n = Abs(Mid(.Value, InStrRev(.Value, "("))) End With For Each c In w.Offset(, -1) Dic(n & "_" & c) = c.Offset(, 1) Next Next With Sheets("Result(было)") m = .UsedRange.Columns.Count n = .Columns(1).SpecialCells(xlCellTypeConstants, 23).Areas.Count Set r = .[A1].CurrentRegion ReDim arr(1 To n * m, 1 To 6) For i = 1 To n For j = 1 To m o = (i - 1) * m + j If Not IsEmpty(r(1, j)) Then For k = 1 To 3 arr(o, k) = r(k, j) Next l = 0 For k = 4 To r.Rows.Count l = l + Dic(arr(o, 2) & "_" & r(k, j)) Next If l Then arr(o, 5) = l s = "" On Error Resume Next With r.Columns(j) arr1 = Intersect(.Offset(3), .Cells).SpecialCells(xlCellTypeConstants, 23) If IsArray(arr1) Then s = Join(Application.Transpose(arr1), "_") ElseIf Not IsEmpty(arr1) Then s = arr1 End If Erase arr1 End With arr(o, 6) = s End If Next Set r = r.End(xlDown).End(xlDown).CurrentRegion n = n + 1 Next End With Application.ScreenUpdating = 0: Application.EnableEvents = 0 With Sheets("+++++").UsedRange Intersect(.Offset(1), .Cells).Clear .Cells(4, 1).Resize(o, 6).Value = arr End With Application.ScreenUpdating = 1: Application.EnableEvents = 1 Set Dic = Nothing Set r = Nothing Set w = Nothing Set c = Nothing Erase arr End Sub
[/vba]
Здравствуйте Как-то так [vba]
Код
Sub sdf() Dim Dic As Object Dim sh As Worksheet Dim r As Range, w As Range, c As Range Dim arr() As Variant, arr1 As Variant Dim i, j, k, l, m, n, o
Set Dic = CreateObject("scripting.dictionary") For Each w In Sheets("Criteria").Cells.SpecialCells(xlCellTypeConstants, 1).Areas With w.Offset(-1, -1).Resize(1, 1) n = Abs(Mid(.Value, InStrRev(.Value, "("))) End With For Each c In w.Offset(, -1) Dic(n & "_" & c) = c.Offset(, 1) Next Next With Sheets("Result(было)") m = .UsedRange.Columns.Count n = .Columns(1).SpecialCells(xlCellTypeConstants, 23).Areas.Count Set r = .[A1].CurrentRegion ReDim arr(1 To n * m, 1 To 6) For i = 1 To n For j = 1 To m o = (i - 1) * m + j If Not IsEmpty(r(1, j)) Then For k = 1 To 3 arr(o, k) = r(k, j) Next l = 0 For k = 4 To r.Rows.Count l = l + Dic(arr(o, 2) & "_" & r(k, j)) Next If l Then arr(o, 5) = l s = "" On Error Resume Next With r.Columns(j) arr1 = Intersect(.Offset(3), .Cells).SpecialCells(xlCellTypeConstants, 23) If IsArray(arr1) Then s = Join(Application.Transpose(arr1), "_") ElseIf Not IsEmpty(arr1) Then s = arr1 End If Erase arr1 End With arr(o, 6) = s End If Next Set r = r.End(xlDown).End(xlDown).CurrentRegion n = n + 1 Next End With Application.ScreenUpdating = 0: Application.EnableEvents = 0 With Sheets("+++++").UsedRange Intersect(.Offset(1), .Cells).Clear .Cells(4, 1).Resize(o, 6).Value = arr End With Application.ScreenUpdating = 1: Application.EnableEvents = 1 Set Dic = Nothing Set r = Nothing Set w = Nothing Set c = Nothing Erase arr End Sub