Добрый день! Подскажите, использую код VBA для сохранения файлов с отчетами, соответствующих определенной маске. Все работает, но есть одна проблема, через outlook создают различные встречи и собрания, и когда такое сообщение приходит в почту, код выдает ошибку, Run-time error '13': Type mismatch. Я так понимаю, что ошибка в связи с тем, что сообщение от календаря не является письмом, а код пытается его обработать. Как-то можно добавить условие, чтобы он такие сообщения игнорировал?
Код
Private Sub Application_NewMail()
Dim myFolder As Outlook.MAPIFolder
Dim mi As MailItem
DestFolder = "D:\путь к папке\"
Set myFolder = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For Each mi In myFolder.Items.Restrict("[Unread]=TRUE")
If mi.Class = olMail Then
If mi.Attachments.Count > 0 Then
For j = 1 To mi.Attachments.Count
If InStr(1, mi.Attachments.Item(j).FileName, "Имя файла", vbTextCompare) > 0 And _
InStr(1, mi.Attachments.Item(j).FileName, Date, vbTextCompare) > 0 Then
If Len(Dir(DestFolder & "файлы " & Date, vbDirectory)) = 0 Then
MkDir DestFolder & "файлы " & Date
End If
Debug.Print (DestFolder & mi.Attachments.Item(j).DisplayName)
mi.Attachments.Item(j).SaveAsFile DestFolder & "файлы " & Date & "\" & mi.Attachments.Item(j).FileName
mi.UnRead = False
End If
Next j
End If
End If
Next mi
End Sub
Добрый день! Поскольку ограничения политики безопасности в организации обойти не удалось, массовая рассылка из макроса VBA в excel недоступна. Я проверил код отправки письма в outlook, и он спокойно работает без всяких ограничений на адресатов. Но... но тут я столкнулся с другой проблемой, вся обработка и создание файла производится в excel в цикле, соответственно каждый цикл должен завершаться отправкой письма, но макрос по отправке письма, если он в outlook не получается вызвать... В интернете я нашел обсуждение аж от 2008 года, где предлагается такой вариант:
Код
Public Sub macroinOutlook()
Dim olookApp As Object
Set olookApp = CreateObject("Outlook.Application")
olookApp.SendMail
Set olookApp = Nothing
End Sub
Но данный недокументированный метод вызывает ошибку 438. Покопавшись еще нашел другое мнение: As far as I can tell, it's not possible to run macros that are stored in Outlook from other applications. Outlook lacks the Application.Run method that is available in Word and Excel. То есть вызвать макрос, который написан в outlook невозможно?
Добрый день! При попытке делать рассылку на сотрудников из файла EXCEL макросом сначала, все отправлялось, потом я немного исправил код, и не знаю, что именно повлияло, но вдруг стало вылазить предупреждение об отправке, где нужно разрешать такую отправку. Интернет дает два способа решения этой проблемы:1 - отключение параметров безопасности, я проверил, у нас на работе они заблокированы, видимо такая политика безопасности. 2 - также пишут, что решает проблему отправка через CDO, поискал как это делается, и там нужно указать сервер, а также логин и пароль учетки, за что мне тоже может достаться от нашей службы безопасности. Вопрос, может еще есть какой-нибудь третий вариант? Может если макрос подписать сертификатом, поможет ли это?
Добрый день! Наши сотрудники часто присылают файлики, где в ячейках в конце после текста куча переносов строк, пример прилагаю. Дело в том, что у меня делается автоподбор высоты, и приходится постоянно перепроверять каждый листик, поскольку руководство не любит когда "некрасиво". Иначе высота строки подбирается неверно. Как можно удалить эти переносы? Вопрос в удалении переносов именно в конце текста. В интернете в основном варианты по сплошному удалению всех переносов в ячейке.
Добрый день! Нужно добиться следующего эффекта: код обрабатывает множество листов, на каждом листе табличка. После выполнения кода, при открытии любого из обработанных листов мы должны увидеть нижний, правый угол таблицы. То есть переместиться в ее конец. Я думал, что достаточно методом Select выбрать правую нижнюю ячейку, но это не помогло. Ячейка выделятся, но когда открываешь лист, видишь верхнюю левую часть листа (ну или любую другую, где сохранил пользователь). Нашел решение через GoTo, но оно визуально тоже не перемещает в нужное место. Может ли это быть связано, с тем что выключено обновление экрана на протяжении всего макроса?
Выдает ошибку object required. А через передачу диапазона в переменную, и потом применение к переменной ClearContents работает...просто хотелось бы избежать лишних строчек.
Я в коде хотел получить более компактную запись ссылаясь на лист не по прямому наименованию, а подстановкой ссылки на лист, приведу пример:
Код
For Each wsBaseSheet In wbAct.Worksheets 'цикл по всем листам в открытой книге
sSheetNameBase = wsBaseSheet.Name ' присваиваем строковой переменной имя листа из открытой книги
If sSheetNameBase = sSheetName Then 'сравниваем имя листа в книге и имя листа в массиве
For b = 1 To arrCol(a)
lRow1 = wbAct.wsBaseSheet.Cells(Rows.Count, b).End(xlUp).Row
Но такой код выдает ошибку, нашел на форумах подход, что лист нужно определить через SET
Попробовал так:
Код
For Each wsBaseSheet In wbAct.Worksheets 'цикл по всем листам в открытой книге
sSheetNameBase = wsBaseSheet.Name ' присваиваем строковой переменной имя листа из открытой книги
Set wsWsheet = wbAct.Worksheets(" & sSheetNameBase & ")
If sSheetNameBase = sSheetName Then 'сравниваем имя листа в книге и имя листа в массиве
For b = 1 To arrCol(a)
lRow1 = wbAct.wsWsheet .Cells(Rows.Count, b).End(xlUp).Row
Но тоже выдает ошибку.. как корректно можно сослаться на лист, если лист у нас определяется перебором переменной в цикле, т.е. я не могу сослаться на конкретный лист, или это невозможно?
Добрый день! Я тут заметил, что когда делаю сравнение двух значений по типу If a.Value = b.Value Then, то у меня сравнение идет с учетом регистра, т.е. а001аа не равно А001АА, этого как можно избежать?
Добрый день! Мне нужно работать с несмежными диапазонами, гистограммы нужно добавить, только в столбы с значениями ( в примере это F и I). Но как передать несмежные диапазоны в range? Метод Union выдает ошибку. Пример прилагаю. Спасибо всем откликнувшимся.
Добрый день! Попытался позаимствовать идею с этого сайта, по внесению в комментарии к ячейки ФИО изменяющего а также предыдущего значения до изменения. Но почему-то выдает ошибку. Я позаимствовал только часть идеи, но как казалось вполне самостоятельную (часть где вносится коммент), в примере мониторятся изменения на листе (эту часть я не брал), и в случае их наличия добавляется комментарий, в моем же случае мне нужно по внесению данных в ячейки с пользовательской формы, прописать кто инициировал собственно это внесение данных... Подскажите в чем проблема? в данном примере я ссылаюсь на cell хотя вообще нужно на cell.offset( ,1). Но раз даже с cell не получается...
Добрый день! Реализовал подтягивание данных на форму путем заполнения combobox1 и сравнения с диапазоном ключевых значений, и соответственно отбором других соответствующих значений из таблицы. Но, к сожалению, было обнаружено, что ключевые номера могут повторятся. Пришлось менять подход. Но не получается. Цель такая, что если номер повторяется два раза, то мы смотрим по столбцам(вправо) где последнее заполненное значение, и берем данные на форму из той строки. Я вот только понять не могу, сначала нужно пройтись словарем по всем строкам а потом запускать цикл проверки совпадения? либо можно это делать сразу в словаре?
Пример во вложении, файл запинается, когда пытаюсь в combobox передать значение ключа.. пытался передавать туда даже просто текстовую строку, все равно не получается, пишет, что данное свойство или метод не поддерживается.. почему? Раньше писал что запрещен доступ, но после добавления обращения к коллекции controls ошибка изменилась...
Public Sub UserForm_Initialize()
Dim dic As Object, cell As Range
Dim arrList(), ikey
Dim lLastrow As Long
TextBox1.Value = Format(Date, "dd.mm.yyyy")
TextBox2.Value = Format(Date, "dd.mm.yyyy")
TextBox3.Value = Format("08:00", "hh:mm")
TextBox4.Value = Format("20:00", "hh:mm")
arrRow = Array(2, 3, 11)
For Each e In arrRow
lLastrow = ActiveSheet.Cells(Rows.Count, e).End(xlUp).Row
Set rList = ActiveSheet.Range(Cells(3, e), Cells(lLastrow, e))
Set dic = CreateObject("Scripting.Dictionary")
For Each cell In rList
If cell.Value <> "" Then
If dic.exists(CStr(cell.Value)) Then dic.Item(CStr(cell.Value)) = CStr(cell.Value) Else _
dic.Item(CStr(cell.Value)) = CStr(cell.Value)
End If
Next cell
For Each ikey In dic.Keys
Me.Controls.ComboBox2.AddItem ikey
Next ikey
Next e
End Sub
Пытаюсь решить следующую задачу: Есть массив, мы его проверяем на наличие значений (в примере 52). И столбцы с этим значением нужно убрать из массива. Решил пойти путем записи номеров столбцов в массив, но при этом соответственно они там не должны повторятся. то есть если во втором столбце 52 встречается два раза записать второй столбец нужно 1 раз. Проблема в том, что вот эту задачу, не повторения я не могу решить. Не понимаю куда воткнуть а=а+1. Спасибо.
Код
Sub Massive()
Dim arrTest() As Variant, arrTest2() As Variant, arrTemp() As Variant, arrTemp2() As Variant
Dim a As LongarrTest = ThisWorkbook.Worksheets(3).UsedRange.Value
ReDim arrTest2(1 To UBound(arrTest, 1), 1 To UBound(arrTest, 2))
ReDim arrTemp(0)
ReDim arrTemp2(0)
a = 0
For i = 1 To UBound(arrTest, 2)
For j = 1 To UBound(arrTest, 1)
If arrTest(j, i) = 52 Then For Each Element In arrTemp2
If Element <> i Then
a = a + 1
ReDim Preserve arrTemp(a)
arrTemp(a) = i
End If
Next
ReDim arrTemp2(0 To UBound(arrTemp, 1))
arrTemp2 = arrTemp
End If
Next j
Next i
Добрый день! Имеется файл, который обрабатывается макросом. В результате обработки некоторые строки превращаются в строку без наименования а просто "прочие". И эта строка может оказаться где угодно. Каким образом (замечательно будет если он работает из VBA) можно сделать так, чтобы эти "прочие" всегда замыкали список? пример во вложении
Добрый день! подскажите, пожалуйста. Как определить номер строки, в которой перестало выполняться условие? Если использовать for each то я переберу все строки, в большом файле это долго, и как мне понять именно первую строку? А как использовать для этого do until не могу понять, как в этом цикле перебирать ячейки? Когда запихиваю Do until в for each зависает excel. Когда for each засовываю do until ругается на ошибку. Пример во вложении. Как определить что в 5 строке уже не Винни а пух.точнее даже неважно что там. Просто там не Винни?
Добрый день! Пытаюсь решить следующую задачу: Есть список по контрагентам, при этом часть из них по факту связаны между собой, а поэтому и рассматривать их нужно вместе. Таким образом 5 строк могут превратиться в одну. Сводной таблицей я могу это сделать, но к сожалению есть сотрудники, которые это сделать не смогут, поэтому оптимальным решением было бы просто нажать кнопку. Плюс в сводной таблице не учитываются не числовые переменные. Попробовал пойти следующим путем: Создаем словарь, идем сверху вниз, при повторении ключа (группа компаний) числовые показатели суммируем, где-то находим максимум, а строку удаляем, таким образом остается одна строка. Но код выдает ошибку. Вопрос, в чем ошибка, как исправить? и есть более оптимальный подход к задаче? просто было бы удобнее, если бы исходная таблица не портилась макросом.
В рамках предыдущего макроса, есть часть, которая должна фактические значения перенести к плану. Суть: есть две таблички, есть некий показатель в виде текста, и правее его значение. В другой табличке точно такой же показатель, и пустая ячейка куда должно встать это значение. Проблема, заранее строку мы не знаем, то есть нам надо найти где это совпадение и перенести значение. Но есть еще одна проблема, совпадения маловероятны, но возможны, поэтому для надежности нужно сверится с фамилией. А эту уже три массива?
Подскажите, как это можно реализовать?
Код
Sub Perenos_znach()
Dim rCely As Range, rResult As Range
Dim sName As String
sName = Workbooks("file1").Worksheets(1).Range("G2")
Set rCely = Workbooks("file1").Worksheets(1).Range("B11:B14")
Set rResult = Workbooks("file2").Worksheets(1).Range("C5:C12")
For Each c In rResult
'If c.Value = rCely ' Тут начинается тупняк...
'Then c.offcet(0, 3).Value =
End Sub
Вобщем, решил вымучить код, думаю так быстрее научиться получится. Но все равно вылазят ошибки, которые не могу решить методом проб и ошибок. Получился вот такой код: (цель кода пройтись по книгам и вытащить данные по каждому сотруднику, но пока что в коде работа с одной книгой иду от частного к общему) Проблемы возникают в следующих строках в комментах. Прошу подсказать если не сложно. Спасибо.
Код
Sub Copy_cely()
Dim sName As String
Dim lNameRow As Long, lLastRow As Long
Dim rRcalc As Range, rNamelist As Range, currCell As Range
Dim wbAct As Workbook
lLastRow = Workbooks("Матрица.xlsm").Sheets(1).UsedRange.Row - 1 + Workbooks("Матрица.xlsm").Sheets(1).UsedRange.Rows.Count
Set rNamelist = ActiveSheet.Range(Cells(1, 1), Cells(lLastRow, 1)) ' здесь я пытался создать объект range содержащий список фамилий, по которому будем искать номер строки
'если выполнять код пошагово, изначально в нем появляются данные, но потом при использовании объекта в Set currCell = rNamelist.Find(What:=sName, SearchFormat:=False)
'пишет, что объект не определен. Почему??? не могу разобраться.
Set wbAct = Workbooks.Open("C:\Users\User1\Desktop\Пользователь\Иванов_Иван.xlsx")' изначально было без Set vbAct но почему-то Workbooks.Close не дает поставить
'false на сохранение изменений. Как закрывать без создания объекта не сохраняя изменения?
With Worksheets("План") ' лист в открытой книге
sName = Range("H2").Value ' в этой ячейке имя фамилия сотрудника, записываем в переменную
Set currCell = rNamelist.Find(What:=sName, SearchFormat:=False) ' тут пытаюсь осуществить поиск по ранее определенному диапазону фамилий,
'здесь и основная проблема вылетает по ошибке 404 object required
Stop ' это нужно писать?
If currCell Is Nothing Then Exit Sub 'здесь выходит хотя фамилия точно есть, видимо в объект ничего не записалось двумя строками ранее
lNameRow = currCell.Row ' определили строку
Set rRcalc = ActiveSheet.UsedRange
For Each c In rRcalc.Cells 'такую запись часто встречал в чужих макросах, использовал и здесь, интересно но при использовании option explicit ругается.
'Как определить эту переменную?
Select Case Name
Case c = "Плановый показатель"
Workbooks("Матрица.xlsm").Sheets(1).Range("U" & lNameRow).Value = c.Offset(0, 1)
Case c = "Количество ошибок"
Workbooks("Матрица.xlsm").Sheets(1).Range("O" & lNameRow).Value = c.Offset(0, 1)
Case c = "Просрочка оплаты"
Workbooks("Матрица.xlsm").Sheets(1).Range("I" & lNameRow).Value = c.Offset(0, 1)
End Select
Next c
End With
wbAct.Close False
End Sub
Попытался доработать макрос, под свои цели. Есть несколько файлов, для примера только два. В каждом содержится таблица с показателями сотрудника. В ячейке Н2 ФИО сотрудника. Необходимо собрать табличку с показателями, кроме нулевых, в первом столбце ФИО сотрудника. При работе возник ряд вопросов, помогите с ответами пожалуйста: 1) If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = Range("H2") Данная строка выдает ФИО, только для первого значения в Union Range("D10:D16") для остальных остается пустой, почему? как исправить? 2) Файлы содержат эл. подпись, поэтому при открытии выдает ошибку "файл поврежден". Из-за этого не работает Set wbAct = Workbooks.Open(Filename:=avFiles(li)) Приходится убирать эл. подпись, но хотелось бы ее сохранить, возможно заставить макрос игнорировать проблему? просто продолжить работать с файлом? 3)Для безопасности, что бы макрос работал именно в табличке куда записали данные хотел добавить With Workbooks("тест реестр.xlsm").Sheets("ПП") Но выдает ошибку, пришлось использовать Select. В каких случаях можно использовать With с листом? Спасибо.
Код
Sub Consolidated_Range_of_Books_and_Sheets()
Dim iBeginRange As Object, lCol As Long
Dim oAwb As String, sCopyAddress As String, sSheetName As String, sSubStr As String, sSubStr2 As String
Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
Dim wsSh As Object, wsDataSheet As Object, avFiles
Dim wbAct As Workbook
Dim bPasteValues As Boolean
Dim arr
Set iBeginRange = Union(Range("D10:D16"), Range("D18:D25"), Range("D27:D28"), Range("F10:H16"), Range("F18:H25"), Range("F27:H28"))
sSheetName = "Лист1"
On Error Resume Next
avFiles = Application.GetOpenFilename("Excel files(*.xls*), *.xls*", , "Выбрать книги", , True)
If VarType(avFiles) = vbBoolean Then Exit Sub
lCol = 1
With Application
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With
Set wsDataSheet = Worksheets("ПП")
For li = LBound(avFiles) To UBound(avFiles)
Set wbAct = Workbooks.Open(Filename:=avFiles(li))
oAwb = wbAct.Name
For Each wsSh In wbAct.Sheets
If wsSh.Name Like sSheetName Then
With wsSh
sCopyAddress = iBeginRange.Address
lLastRowMyBook = wsDataSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = Range("H2")
.Range(sCopyAddress).Copy
wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValuesAndNumberFormats
End With
End If
Next wsSh
wbAct.Close False
Next li
'---------------------------------------------------------------------------
Workbooks("тест реестр.xlsm").Sheets("ПП").Select
sSubStr = "0"
lCol = 2
lLastrow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
arr = Cells(1, lCol).Resize(lLastrow).Value
Dim rr As Range
For li = 1 To lLastrow
If CStr(arr(li, 1)) = sSubStr Then
If rr Is Nothing Then
Set rr = Cells(li, 1)
Else
Set rr = Union(rr, Cells(li, 1))
End If
End If
Next li
If Not rr Is Nothing Then rr.EntireRow.Delete
'---------------------------------------------------------------------------
With Application
.ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic
End With
End Sub
Добрый день. Подскажите, почему когда оборачиваю дату функцией =ТЕКСТ(04.06.2016;"ддммгггг") в итоге получаю 04002016, то есть день и год нормально, а месяц не идет? пример прилагается.
Добрый день. Использую данный код для поиска дубликатов в таблице, но проблема в том, что он ищет скорее не дубликаты а повторы значений. В итоге в определенной строке я получаю кол-во повторов одного значения, но начиная с повтора(!). А как можно поправить код, что бы он и у первого значения, которое в дальнейшем повторяется тоже проставлял повтор, то есть отмечать именно пару дубликатов? И еще вопрос, если не возражаете, на что поменять h(c.Value) в 11 строке кода, что бы он проставлял не повтор, а значение из ячейки c.offset (0, 9) но не текущего значения а повтора, то есть если дубликат в 11 строке и в 80, то в 11 он поставит значение из 80 (+ 9 ст) а в 80 наоборот из 11? Или это со словарем вообще не реализовать? Или может его можно запустить снизу вверх?
Код
Sub getTheSame()
On Error GoTo errh: 'Устанавливаем хендлер ошибок
Dim h As New Scripting.dictionary 'Создаем хеш - множество пар "ключ" -> значение
Dim rg As Range
Set rg = Columns(9).Cells.SpecialCells(xlCellTypeConstants) 'Берем только константы из колонки 9
For Each c In rg.Cells 'Перебираем все ячейки из множества
DoEvents 'Даем Экселю возможность отрисоваться
ActiveWindow.Caption = c.Address 'Можно еще адрес ячейки показывать - чтоб был виден прогресс
h(c.Value) = h(c.Value) + 1 ' Если ключ не существовал, хеш его автоматически добавит, иначе увеличит к-во повторений ключа
If h(c.Value) > 1 Then 'Если ключ встречался более 1 раза
c.Offset(0, 15).Value = h(c.Value)
End If
Next c
Set h = Nothing 'Освобождаем память из под хеша
MsgBox "Done", vbInformation ' Ну и для наглядности плакат об окончании
'=============================
If 0 Then 'Сюда попадем только в случае ошибки
errh: 'В обычных условиях if 0 никогда не сработает
Set h = Nothing 'Если возникла ошибка - освобождаем память из под хеша
MsgBox Err.Description 'Выводим сообщение об ошибке
End If
'==============================
End Sub
Добрый день. Необходио раскидать платежи по временным карманам. Изначально таблицы выглядит как сумма контракта и дата начала контракта (выделено голубым). Затем я наращиваю таблицу вправо, таким образом формуирая ежемесячные платежи и их даты. Далее при помощи формул раскидваю по срокам. Но столкнулся с такой проблемой, что при моем подходе формулы получаются бессконечно длинными. Таблицы намного длиннее, чем в примере и достигает многих 100 строк. Есть ли возможность раскидать по временным карманам более оптимально? не нагромождая суммы одинаковых формул?
Добрый день. Мне необходимо плановые данные раскидать по срокам. Это я сделал с помощью формулы "суммпроизв". Но помимо этого мне нужно еще погашения размещенных активов тоже раскидать по срокам. И тут я застрял, никак не пойму в каком направленнии модифировать формулу. Накидал приблизительно пример, как это выглядит в очень упрощенном виде. Суть в том, что погашения происходят по определенным коэффициентам которые расчитаны помесячно. Таким образом в итоге получается что для каждого размещения будет свой график возврата. Так например размещение в первом месяце, даст первый возврат уже во втором, в третьем месяце будет второй возврат + первый возврат от размещения во втором месяце. Пытался это реализовать через кучу "суммпроизв" в итоге получилась формула длиной с метр, при этом, стоило изменить дату, как все начинало считаться неверно. Вобще возможно ли тут формулой справиться? Сейчас пытаюсь реализовать альтернативный план, расчитать график для каждого размещения а потом уже его подсчитывать, но для этого нужен доп лист, что не совсем удобно (прийдется его скрывать), поэтому если кто-то знает как решить эту головолмку буду очень признателен.