Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 15 След.
Надстройка для обработки большого объема данных с аналитикой
 
Прототип конец месяца, далее видно будет
Если очень захотеть - можно в космос полететь ;)
Надстройка для обработки большого объема данных с аналитикой
 
В виду отсутствия времени, готов либо передать полностью проект в работу, либо часть работ по проекту (обсуждаемо)
Кратко суть:
Есть 2 отчета выгруженных из 1с
-Обороты
-Остатки
Все это со всей сопутствующей информацией начиная от контрагентов заканчивая бухгалтерскими счетами, все это организовано в виде таблиц (если нужны будут какие то другие форматы, готовы переделать выгрузки из 1с)
Что хотят на основе текущих данных
-Строить такие отчеты как
Баланс
отчет о прибылях и убытках
Обороты по счетам
Оборотно сальдовая ведомость и тд (около 6 отчетов)
Далее самое интересное, после формирования текущих отчетов должна быть возможность просматривать аналитику, т.е. грубо при выборе  какой-то строки должна появится таблица типа сводной, где можно добавить поля фильтры и тд, далее при клике на строке еще глубже проваливаемся и тд последний уровень это бухгалтерские проводки!
Все это хотят организовать в виде надстройки, с вероятностью продавать дальше!
Бюджет с конечным заказчиком еще не утвержден, ждут ответа о том работаем или нет!  
Если очень захотеть - можно в космос полететь ;)
Отправка документа в телеграм
 
Многоуважаемые коллеги, пытаюсь реализовать отправку документа в телеграмм, текущий код выдает ошибку о превышении времени ожидания, подскажите что не так, вот собственно код:
Код
Sub trrrr() 
sURL = "https://api.telegram.org/bot" 
apikey = "5000XX47:XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" 
chat_id = "XXXXXXXXX" 
Const Boundary As String = "-----------test---------" 
URL = sURL & apikey & "/sendDocument" 
sFile = "C:\Users\lexey\Downloads\LOG.txt" 'файл
Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1") 
oHttp.Open "POST", URL, False 
oHttp.setRequestHeader "Connection", "keep-alive" 
oHttp.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & Boundary 
FrmData = Boundary & vbNewLine 
FrmData = FrmData & "Content-Disposition: form-data; name=" & Chr(34) & "chat_id" & Chr(34) & ";" & vbNewLine & vbNewLine 
FrmData = FrmData & chat_id & vbNewLine & vbNewLine 
FrmData = FrmData & Boundary & vbNewLine 
FrmData = FrmData & "Content-Disposition: form-data; name=" & Chr(34) & "document" & Chr(34) & "; filename=" & Chr(34) & sFile & Chr(34) & vbNewLine & vbNewLine 
FrmData = FrmData & Boundary & "-" 
oHttp.send FrmData: DoEvents 
Debug.Print FrmData 
'Debug.Print oHttp.responseText 
Set oHttp = Nothing 
End Sub 
Если очень захотеть - можно в космос полететь ;)
POST-запрос для авторизации на сайте
 
Игорь, спасибо, логин пароль для теста есть :
Код
сlogin = "lexey_fan%40list.ru"
cPass =  "123456789"
Пробовал брать token и csfr с сайта, но при этом, если отправляю post запрос выкидывает на 404, если Get то просто не авторизовывает!
Если вручную авторизовываться то капчу не показывает
Изменено: lexey_fan - 9 Фев 2017 07:57:44
Если очень захотеть - можно в космос полететь ;)
POST-запрос для авторизации на сайте
 
Сергей,спасибо!  да увидел, и поля с типом "Hidden"  token и csfr, но не смог "расковырять" функцию которая их генерирует
Если очень захотеть - можно в космос полететь ;)
POST-запрос для авторизации на сайте
 
ZVI, да заметил что ошибся с переменой (копировал через телефон, что то подправлял, видимо просто ошибся), спасибо,  а по поводу отличия формирования строки login от того что делал Сергей, сам сайт citilink изменил строку авторизации поэтому вносил правки, какое то время работало  
Если очень захотеть - можно в космос полететь ;)
POST-запрос для авторизации на сайте
 
Доброго дня, С Вашего позволения подниму тему повторно, не удается что-то разобраться почему не авторизовывается, можете подсказать как поправить
Код
Sub AUTH()
    Dim xmlWeb
    Set xmlWeb = CreateObject("Msxml2.ServerXMLHTTP")
    'On Error Resume Next
сlogin = "lexey_fan%40list.ru"
cPass =  "123456789"
    login$ = "https://login.citilink.ru/auth/login/?from=https%3A%2F%2Fwww.citilink.ru%2F&login=" & clogin & "&pass=" & cPass
    'для авторизации (тестовый логин /пароль)
    With xmlWeb
        .Open "GET", login$, False
        'заголовки запроса
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
        .setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.3; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/42.0.2311.90 Safari/537.36"
        .Send: DoEvents  
        .Debug.print   .responseText
        If .Status = 200 Then
            If InStr(1, .responseText, "/logout/", vbTextCompare) > 0 Then
                MsgBox "OK"
            End If
        End If
    End With
End Sub
Если очень захотеть - можно в космос полететь ;)
Макрос для автоматического изменения высоты объединенных строк
 
Добрый день, подумал, именно изменение размера высоты ячейки под текст,не совсем тривиальная задача, а вот просто скрытие объединенных ячеек в случае отсутствия в них какого рода информации и отображение в случае появления набросал вот
Код
Sub test()
On Error Resume Next
Dim coll As New Collection
Dim iRange As Range
Dim iCell As Range
   Set iRange = ActiveSheet.UsedRange
      For Each iCell In iRange
         If iCell.MergeCells Then
            coll.Add iCell.MergeArea.Address, iCell.MergeArea.Address
               If Err.Number = 0 Then
                  If iCell.Value = "" Then iCell.MergeArea.RowHeight = 0 Else iCell.MergeArea.EntireRow.AutoFit
               Else
                  Err.Clear
               End If
         End If
      Next
End Sub
А вот и попробовал что то придумать (Файл приложил):
Код
Sub test()
On Error Resume Next
Application.ScreenUpdating = False
Dim coll As New Collection
Dim iRange As Range
Dim iCell As Range
Set iRange = ActiveSheet.UsedRange
For Each iCell In iRange
If iCell.MergeCells Then
coll.Add iCell.MergeArea.Address, iCell.MergeArea.Address
If Err.Number = 0 Then
If iCell.Value = "" Then
iCell.MergeArea.RowHeight = 0
Else
y = iCell.MergeArea.ColumnWidth
Set sh = Sheets.Add
With sh.Cells(1, 1)
  .HorizontalAlignment = iCell.MergeArea.HorizontalAlignment
  .VerticalAlignment = iCell.MergeArea.VerticalAlignment
  .WrapText = True
  .ColumnWidth = y * iCell.MergeArea.Columns.Count
  .Value = iCell.Value
  .EntireRow.AutoFit
  x1 = .RowHeight
End With
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
iCell.MergeArea.RowHeight = x1 / iCell.MergeArea.Rows.Count
End If
Else
Err.Clear
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Изменено: lexey_fan - 12 Июл 2016 22:43:54 (Добавлен код и файл)
Если очень захотеть - можно в космос полететь ;)
макрос Microsoft Outlook 2010(копирование вложений по имени вложения)
 
вот в своё время изобретал:  
- обрабатывает входящее сообщения  и кладёт вложения в опр папку с наименованием согласно адресу
- работает с MAPI
- переписывает адрес входящего сообщения согласно адресной книги
---- Возможно поможет чем то!
Код
Private Sub Application_NewMailex(ByVal EntryIDCollection As String)
Путь = "E:\MAIL\Входящие\" 'папка для сохранения вложения
Set oNamespace = Application.GetNamespace("MAPI")
Dim arr() As String
Dim i As Integer
Dim m As MailItem
On Error Resume Next
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set m = Application.Session.GetItemFromID(arr(i))
If UCase$(m.SenderEmailType) = "EX" Then
Set recip = oNamespace.CreateRecipient(m.SenderEmailAddress)
Set exUser = recip.AddressEntry.GetExchangeUser()
sAddress = exUser.PrimarySmtpAddress
Else
sAddress = m.SenderEmailAddress
End If
t = iname(sAddress)
If t = "" Then t = m.SenderName
m.SentOnBehalfOfName = t
m.Save
If m.Attachments.Count > 0 Then
If Len(Dir(Путь & t, vbDirectory)) = 0 Then 'проверка существования директории
MkDir Путь & t 'делаем папку с t
End If
For j = 1 To m.Attachments.Count
m.Attachments.Item(j).SaveAsFile Путь & t & "\" & Date & " " & m.Attachments.Item(j).DisplayName
Next j
End If
m.UnRead = False
Next
End Sub

Function iname(t)
'On Error Resume Next
Dim myNameSpace As NameSpace
Dim myFolder As MAPIFolder
Dim myWorkFolder As MAPIFolder
Dim iContact As ContactItem
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myWorkFolder = myFolder
For Each iContact In myWorkFolder.Items
'Debug.Print iContact.Email1Address & "---->" & UCase$(iContact.Email1AddressType)
If UCase$(iContact.Email1AddressType) = "EX" Then
Set recip = myNameSpace.CreateRecipient(iContact.Email1Address)
Set exUser = recip.AddressEntry.GetExchangeUser()
sAddress = exUser.PrimarySmtpAddress
Else
sAddress = iContact.Email1Address
End If
If sAddress = t Then iname = iContact
Next iContact
End Function
Если очень захотеть - можно в космос полететь ;)
При вставке изображения на форму вылетает ошибка 481
 
Картинки выгружаю на ресурс не я, поэтому была проблемка, победил её следующим образом (Правда костыль, но работает)
Закидываю на лист картинку, и сохраняю ее обратно на комп с заменой предыдущей
Код
Function convert(sfile) As String
 Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 Dim sName As String, oObj As Object
   sName = sfile
    Set Tmp = Worksheets.Add
    Tmp.Pictures.Insert(sName).Select
    Set oObj = Selection: oObj.Copy
    With Tmp.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart
        .ChartArea.Border.LineStyle = 0
        .Paste
        .Export FileName:=sName, FilterName:="jpg"
        .Parent.Delete
    End With
    Tmp.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Function
Изменено: lexey_fan - 21 Май 2015 14:22:48
Если очень захотеть - можно в космос полететь ;)
При вставке изображения на форму вылетает ошибка 481
 
В основном на эту ошибку грешат что не поддерживаемый формат изображения, грешу на то что изображение с расширением jpg но при этом имеет другой формат, т.к. изображение без фона, пробовал пересохранить Pain'том в .bmp (выводилось сообщение что прозрачность будет недоступна), после чего картинка подгружалась без ошибок!
Как вариант дописать пересохранение через paint, но не хотелось бы...
Если очень захотеть - можно в космос полететь ;)
При вставке изображения на форму вылетает ошибка 481
 
Доброго дня коллеги подскажите, намекните или ткните носом :D
есть изображение Картинка При скачивании и вставке на форму Вылетает ошибка 481 invalid picture
Пробовал сохранять ручками сохранять картинку с сайта через Сохранить Как результат тот же,
Вот так вставляю картинку

Код
Image1.Picture = LoadPicture(ТамГдеКартинка)
Изменено: lexey_fan - 19 Май 2015 16:46:02
Если очень захотеть - можно в космос полететь ;)
POST-запрос для авторизации на сайте
 
Doober, Спасибо Вам большое!
Если очень захотеть - можно в космос полететь ;)
POST-запрос для авторизации на сайте
 
Фёдор, согласен, уменьшил :)
Если очень захотеть - можно в космос полететь ;)
POST-запрос для авторизации на сайте
 
Доброго дня, обращаюсь за советом или подсказкой, в решении вопроса авторизации на сайте путём POST -запроса сайт интернет магазин citilink.ru, путём "курения" интернета соорудил вот такое
Код
Sub AUTH()
Dim xmlWeb As New WinHttpRequest
Dim POST() As Byte, DataPost$
'On Error Resume Next
    login$ = "https://login.citilink.ru/auth/login/?from=&back=citilink.ru"
    DataPost = "email=lexey_fan%list.ru&pass=123456789&passOk=false" 'для авторизации (тестовый логин /пароль)
    POST = StrConv(DataPost, vbFromUnicode)
With xmlWeb
    .Open "POST", login$, False
    'заголовки запроса
   .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   .setRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
   .setRequestHeader "Connection", "keep-alive"
 '  .setRequestHeader "Content-Type", "text/html" ' при этом заголовке выдаёт что фал существует
   .setRequestHeader "Keep-Alive", "timeout=15"
   .setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
   .setRequestHeader "Accept-Encoding", "gzip, deflate"
   .setRequestHeader "Host", "login.citilink.ru"
   .setRequestHeader "Origin", "http://www.citilink.ru"
   .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.3; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/42.0.2311.90 Safari/537.36"
   .setRequestHeader "Referer", login$
   .Send (POST): DoEvents ' отправка запроса авторизации
   If .Status = 301 Then  msgbox "OK"
end with
   End sub

Если переменная login вида https.... то выдаёт ошибку операция отменена, если http то статус получает равны 200, при этом авторизация не проходит!
заранее спасибо за внимание к вопросу!
Изменено: lexey_fan - 21 Апр 2015 14:30:10
Если очень захотеть - можно в космос полететь ;)
Создать макросы для формы, создать и объяснить все макросы для формы
 
коллеги, а кто то взялся уже или ещё нет?
Если очень захотеть - можно в космос полететь ;)
Доработать простую HRM систему в ИТ компании до 100 сотрудников за $$$.
 
У нас в организации в 1с реализовано:   1. отмечается приход сотрудника, + в случае опоздания сразу делается сумма к вычету из зп (факт опоздания 50р + каждая минута по 3 руб), у одного человека есть права редактировать этот справочник, дабы убирать оправданные опоздания  2. Допустим я могу просматривать только то что я сделал (документы, реализации, мой график отработанного времени и тд)  3. реализована система постановки задач сотрудникам, отделам - при этом назначить контролирующих  и ещё много вкусностей ! При всём при этом 1с 8  последних версий имеет возможность работы через браузер, следовательно из любого места где есть интернет... так что, скорее всего проще и целесообразней склоняться к решению на базе 1с.
Если очень захотеть - можно в космос полететь ;)
Создание комбинаций товаров с условием
 
Спасибо Вам огромное!
Если очень захотеть - можно в космос полететь ;)
Создание комбинаций товаров с условием
 
Доброго дня, думаю вот над такой задачкой, возможно кто то сталкивался с подобным, есть перечень товара и кол-во товара, есть число (общее кол-во товара  которое мы не можем превысить) нужно получить  варианты групп товаров,  чтобы их кол-во не превышало допустимую сумму. В примере тоже есть описание, + мои потуги (они и сейчас в процессе придумывания и переделывания), рад буду любому совету! спасибо!
Если очень захотеть - можно в космос полететь ;)
Когнитивная модель в excel, Математическое моделирование
 
Как-то интересно, поделитесь тоже ТЗ, просто интерес!  :D
Если очень захотеть - можно в космос полететь ;)
В компанию требуется Аналитик, Знание Excel - не ниже средних; VBA - как минимум уметь править записанное рекордером
 
эх, да, жаль что в Москве  :( , давно думаю работу сменить))
Если очень захотеть - можно в космос полететь ;)
Ошибка : automation error вызванный объект был отключен от клиентов после запуска макросв
 
B.Key, этот макрос висит в общей книге макросов и запускается не из того файла, а т.к. по доброте душевной помогаю бескорыстно, то и особых потуг делать не охото)))
Если очень захотеть - можно в космос полететь ;)
Ошибка : automation error вызванный объект был отключен от клиентов после запуска макросв
 
Нашёл решение,
Код
wb.Sheets(Array(AName1, AName2, AName3, AName4, AName5, AName6, AName7, AName8, AName9, AName10, AName11, AName12, AName13, AName14, AName15, AName16, AName17, AName18, AName19)).Copy after:=wb_2.Sheets(wb_2.Sheets.Count)
листы скопировал по одному, всё прошло без ошибок, но скорость работы стала маленькой((
Если очень захотеть - можно в космос полететь ;)
Ошибка : automation error вызванный объект был отключен от клиентов после запуска макросв
 
Друзья, вот тут есть такой макрос, вернее их было 13 и для каждого листа запускался отдельно, но высыпал ту же ошибку (automation error вызванный объект был отключен от клиентов после запуска макросов), решил исправить макрос, но не отходя долеко от шаблона исходного макроса, если я пробегаю по макросу через клавишу F8 то ошибок не возникает, если запускаю макрос ошибка и может быть при 2 проходе цикла, а может и на 5, если есть мысли как и что, посоветуйте, если нужен файл откуда берутся данные, то он тут , мозг кипит...((
Код
Application.ScreenUpdating = False
    Myarr = Array("ГСПП1", "ГСПП2", "ГСПП3", "ГСПП4", "ГСПП5", "ГСПП6", "ГСПП7", "ГСПП8", "ГСПП9", "ГСПП10", "ГСПП11", "ГСПП12", "ГСПП13")
Set wb = Workbooks.Open("C:\Users\lex\Desktop\Распределение планов.xlsx")
iPath = "C:\Users\lex\Desktop\Doki\" '-путь для сохранения
For Each sh In Myarr
iFileName = Sheets(sh).Cells(1, 4) '-имя при сохранении файла
AName1 = Sheets(sh).Range("C1")                           '-указываем ячейку с нахождением имени ГСППа
AName2 = Sheets(sh).Range("C2")
AName3 = Sheets(sh).Range("C3")
AName4 = Sheets(sh).Range("C4")
AName5 = Sheets(sh).Range("C5")
AName6 = Sheets(sh).Range("C6")
AName7 = Sheets(sh).Range("C7")
AName8 = Sheets(sh).Range("C8")
AName9 = Sheets(sh).Range("C9")
AName10 = Sheets(sh).Range("C10")
AName11 = Sheets(sh).Range("C11")
AName12 = Sheets(sh).Range("C12")
AName13 = Sheets(sh).Range("C13")
AName14 = Sheets(sh).Range("C14")
AName15 = Sheets(sh).Range("C15")
AName16 = Sheets(sh).Range("C16")
AName17 = Sheets(sh).Range("C17")
AName18 = Sheets(sh).Range("C18")
AName19 = Sheets(sh).Range("C19")
Set wb_2 = Workbooks.Add
wb.Activate
wb_2.SaveAs Filename:=iPath & iFileName & ".xlsx": DoEvents
wb.Sheets(Array(AName1, AName2, AName3, AName4, AName5, AName6, AName7, AName8, AName9, AName10, AName11, AName12, AName13, AName14, AName15, AName16, AName17, AName18, AName19)).Copy after:=wb_2.Sheets(wb_2.Sheets.Count)
With wb_2
Application.DisplayAlerts = False
    '.Sheets("1").ScrollWorkbookTabs Position:=xlLast
.Sheets("1").Visible = False
.Sheets("2").Visible = False
.Close 1
    End With 
Application.DisplayAlerts = True
    Set wb_2 = Nothing
    Next
    Application.ScreenUpdating = True
    wb.Close 1
 
Если очень захотеть - можно в космос полететь ;)
Макрос, Редактирование макроса
 
в модуле 281 в Personal, замените в строке
Код
Sheets[Array(AName1, AName2, AName3, AName4, AName5, AName6, AName7, AName8, AName9, AName10, AName11, AName12, AName13, AName14, AName15, AName16, AName17, AName18, AName19)].Copy
квадратные скобки на круглые вот так:
Код
Sheets(Array(AName1, AName2, AName3, AName4, AName5, AName6, AName7, AName8, AName9, AName10, AName11, AName12, AName13, AName14, AName15, AName16, AName17, AName18, AName19)).Copy
в остальном не ковырял!
Изменено: lexey_fan - 13 Окт 2014 18:08:11
Если очень захотеть - можно в космос полететь ;)
Макрос, Редактирование макроса
 
Почта в профиле, присылайте
Если очень захотеть - можно в космос полететь ;)
Макрос, Редактирование макроса
 
Покажите пример пожалуйста
Если очень захотеть - можно в космос полететь ;)
Делимся..., разным
 
alexthegreat, Примите самые искренние поздравления))  ;)
Если очень захотеть - можно в космос полететь ;)
Делимся..., разным
 
Владимир,JayBhagavan,  Спасибо, меня другие материалы  последнее время увлекают и оч сильно)) вот  , только из за этого можно быть не совсем трезвым)))
Если очень захотеть - можно в космос полететь ;)
Делимся..., разным
 
Вот а я женился))
Если очень захотеть - можно в космос полететь ;)
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 15 След.
Наверх