Привет! Расскажите, пожалуйста, как не нарваться на вирусы в файлах excel, например, с форума, делаете ли вы что-то, чтобы себя обезопасить, встречали ли их?
В примере ничего не видно, подключение к вашему шерпойнту, уберите из запроса жёстко заданные шаги, например поищите на ютуб как развернуть всё столбцы. если ругается, значит действительно столбца нет или поменялось его название
Добрый день, уважаемые формучане. Прошу подсказать, есть макрос, который перебирает значения из диапазона и вставляет их как значение фильтра в другие листы. Но не во всех листах есть подходящие значения и при фильтрации ничего не выдает, но макрос всё равно обрабатывает пустой диапазон и шапку и переносит на след. лист.
Пример прилагаю, в городе Самара нет Сидорова, в Пензе нет Иванова, а на выходе всё равно получается Сидоров_, Иванов_
Код
Sub Splitter()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim h As Integer
Dim wrksht As Worksheet
Dim oListObj As ListObject
For h = 2 To Sheets.Count
Set wrksht = ActiveWorkbook.Worksheets(h)
Set oListObj = wrksht.ListObjects(1)
For Each cell In Range("ФИО")
Sheets(wrksht.Name).Select
FinalCol = Cells(1, Application.Columns.Count).End(xlToLeft).Column
FinalRow = Cells(Application.Rows.Count, 1).End(xlUp).Row
Range(oListObj.Name).AutoFilter Field:=FinalCol, Criteria1:=cell.Value
Range(Cells(1, 1), Cells(FinalRow, FinalCol)).SpecialCells(xlCellTypeVisible).Copy
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Paste
ActiveSheet.Name = cell.Value & "_" & Cells(2, FinalCol - 1).Value
ActiveSheet.UsedRange.Columns.AutoFit
Next cell
Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
Добрый вечер! Есть еженедельные отчёты, например, Feb' Отчет и Dashboard 01.03.2020. В первом меняется месяц выпуска, во втором - дата. Настроена параметризация путей к данным в Power Query, но я каждый раз убираю переменные в названии, оставляю только Отчёт и Dashboard. Подскажите, пожалуйста, можно ли настроить, чтобы формула в ячейке искала определенные слова (*Отчёт.xlsx и Dashboard*.xlsx) в названии файла и не приходилось каждый раз переменные удалять?
Понимаю, что вопрос не сколько к PQ, сколько к формулам Excel.
Оставлю здесь свой макрос, он сохраняет выделенные листы в отдельные файлы и создаёт зип-архив с ними
Код
Sub CreateNewZip(sPath As String)
If Dir(sPath) <> "" Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Sub расслитовка()
Dim s As Worksheet
Dim wb As Workbook
Dim pQuery As WorkbookQuery
Dim aw As Window
Set wb = ActiveWorkbook
Set aw = ActiveWindow
For Each s In aw.SelectedSheets
Set tempwindow = aw.NewWindow
Application.ScreenUpdating = False
s.Copy
For Each pQuery In ActiveWorkbook.Queries
pQuery.Delete
Next
tempwindow.Close
Application.DisplayAlerts = False
Dim full_path As String
Dim folder_path As String
folder_path = wb.Path & "\" & "База региона " & s.Name & " " & Date & ".zip"
full_path = wb.Path & "\" & "База региона " & s.Name & " " & Date & ".xlsx"
ActiveWorkbook.SaveAs full_path
Call ZIPOneFile(folder_path, full_path)
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
End Sub
Function ZIPOneFile(sZIPFileName As String, sFileToZIP As String)
Dim objShell As Object
Dim lcnt As Long
Set objShell = CreateObject("Shell.Application")
'создаем пустой ZIP-архив, если его еще нет
If Dir(sZIPFileName, 16) = "" Then
CreateNewZip (sZIPFileName)
End If
lcnt = objShell.Namespace((sZIPFileName)).Items.Count
'помещаем файлы из папки в архив
objShell.Namespace((sZIPFileName)).CopyHere CStr(sFileToZIP)
'дожидаемся окончания архивации
Do Until objShell.Namespace((sZIPFileName)).Items.Count = lcnt + 1
DoEvents
Loop
End Function
Добрый вечер. Динамический массив с ссылкой на форматированную таблицу, тогда при изменении исходной таблицы, будет меняться сам массив. Почитайте у Николая Павлова про динамические массивы.
Требуется отсечь истёкшие договоры. Подскажите, пожалуйста, как сделать фильтр в PQ динамическим, когда ставишь фильтр "после" и кнопку "сегодня", получается конкретная дата:
Код
= Table.SelectRows(#"Измененный тип", each [Дата окончания контракта] > #date(2020, 1, 16))
Андрей VG, не получается, как у вас. Не подскажете, в чём проблема, как вместо количества вывести значения условий платежа и описаний условий платежа.
И это просто сводная, в реале я объединяю информацию с помощью PQ из нескольких файлов, хотелось бы понять как сгруппировать строки с одинаковыми ИД в одну, и использовать в дальнейших объединениях.
Прошу подсказать решение: имеется таблица с ИД клиента, условием платежа и описанием условия платежа. Из-за того, что у одного клиента могут быть разные условия платежа, ИД клиента в таблице повторяется по нескольку раз. Можно ли сгруппировать имеющиеся условия платежа и описания условия платежа в одну строку через слэш по ИД клиента, чтобы исключить повторения?
Ігор Гончаренко, я всё прекрасно понимаю, но в том то и дело, что мне нужно было знать не как совершить эти действия, а как обратиться к объекту, который получается в результате работы продедуры sheets.copy. Как только узнала, получился тот макрос, который я хотела. Оставлю здесь, как сохранить выбранные листы с определённым названием в отдельные книги с последующим их закрытием.
Код
Sub primer()
Dim s As Worksheet
Dim iPath As String
iPath = ThisWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim AW As Window
Set AW = ActiveWindow
For Each s In AW.SelectedSheets
Set TempWindow = AW.NewWindow
s.Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
ActiveWorkbook.SaveAs iPath & "\" & Range("B3") & Range("B2") & ActiveSheet.Name & ".xls", FileFormat:=56
ActiveWorkbook.Close
TempWindow.Close
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Прошу прощения за корявое ТЗ, не знала, что когда создаётся копия листа, это фактически книга. Kuzmich, спасибо, то что,надо. Путаница вызвана тем, что изначально меня просили, чтобы книга целиком сохранялась с названием текущего листа, значения вместо формул и удалялись остальные листы, потому что если вынести в новую книгу сразу конкретный лист, программа не принимает этот формат.
Добрый вечер, форумчане. Подскажите, как совершать манипуляции с копией листа? Пока получается только задействовать активную книгу, что не есть хорошо, она должна оставаться целой, как шаблон. Нужно вынести лист в отдельную книгу, зазначить сумму, сохранить и закрыть. Пример прилагаю.
Код
Sub RandW()
Dim wb As Workbook
Dim s As Worksheet
Dim AW As Window
Set wb = ActiveWorkbook
Set AW = ActiveWindow
Application.DisplayAlerts = False
'преобразование формул в значения на текущем листе
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
On Error Resume Next
For Each s In Sheets
If Not s Is ActiveSheet Then s.Visible = xlSheetVisible: s.Delete
Next
' Application.Quit
ActiveWorkbook.SaveCopyAs wb.Path & "\" & Range("B1") & Range("B2") & ActiveSheet.Name & ".xls"
Application.DisplayAlerts = True
End Sub
Не помогло. Если вставить таблицу в файл Дмитрия - работает, а если скопировать его код к себе - нет.
Текст макроса привожу ниже:
Код
Option Explicit
Sub Send_Mail()
Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
Application.ScreenUpdating = False
On Error Resume Next
'пробуем подключиться к Outlook, если он уже открыт
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear 'Outlook закрыт, очищаем ошибку
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If
objOutlookApp.Session.Logon
Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение
'если не получилось создать приложение или экземпляр сообщения - выходим
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
sTo = "AddressTo@mail.ru" 'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
sSubject = Range("AF4") 'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
sBody = "Странно, что не отображается " & Range("B9") & "\Microsoft\Signatures\"
Dim sTblBody As String
sTblBody = ConvertRngToHTM(Selection)
'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
sAttachment = "C:\Temp\Книга1.xls" 'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
'создаем сообщение
With objMail
.To = sTo 'адрес получателя
.CC = "" 'адрес для копии
.BCC = "" 'адрес для скрытой копии
.Subject = sSubject 'тема сообщения
.Body = sBody 'текст сообщения
'.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
.Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
'.Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
.Display
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
End Sub
Function ConvertRngToHTM(rng As Range)
Dim fso As Object, ts As Object
Dim sF As String, resHTM As String
Dim wbTmp As Workbook
sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'переносим указанный диапазон в новую книгу
rng.Copy
Set wbTmp = Workbooks.Add(1)
With wbTmp.Sheets(1)
'вставляем только ширину столбцов, значения и форматы
.Cells(1).PasteSpecial xlPasteColumnWidths
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).PasteSpecial xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
'удаляем все объекты(фигуры, рисунки и пр.)
'------------------------------------------
'если рисунки и объекты нужны - удалить этот блок
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
'------------------------------------------
End With
'сохраняем книгу как Веб-страницу(чтобы содержимое конвертировать в HTML-код)
With wbTmp.PublishObjects.Add( _
SourceType:=xlSourceRange, Filename:=sF, _
Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'открываем созданный файл как текстовый и считываем содержимое
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
resHTM = ts.ReadAll
ts.Close
'выравниваем таблицу по левому краю(если надо оставить по центру - удалить эту строку)
ConvertRngToHTM = Replace(resHTM, "align=center x:publishsource=", "align=left x:publishsource=")
'закрываем временную книгу и удаляем
wbTmp.Close False
Kill sF
'очищаем объектные переменные
Set ts = Nothing: Set fso = Nothing
Set wbTmp = Nothing
End Function
Добрый вечер, форумчане. Взяла код Дмитрия (The_Prist) для формирования письма Outlook с таблицей из Excel и в этом месте случился затык - не происходит ничего. Вроде бы и макросе прописала нужный диапазон, и в функции, а таблица не вставляется. Нужна вставка в письмо диапазона A4:B11
*PS и подпись меня подводит, подпись, как ты могла?
Дмитрий, в основном файле несколько листов, я хочу, чтобы после обновления данных с помощью PQ, эти листы выносились в отдельные книги, рвались связи с PQ и выгружались на ресурс. Необязательно даже архивировать, нужно, чтобы конечные пользователи не могли вносить изменения в книгу - максимум - фильтрация.
Код не смогла опробовать - на NewZip, опять упирается в то,что Excel 2013?
Дмитрий, спасибо - пофиксила. Подскажите, можно ли задать название архива, исходя из названия вкладки: в моем основном файле их несколько,макросом выношу в отдельные файлы и надо,чтобы они заархивировались согласно названия вкладки.
ctacon, всё верно - работает. Не подскажете, как быть с архивацией и выкладкой по заданному пути? в текущем макросе архивирует, но при открытии архива ругается, что формат файла не соответствует его разрешению