Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
После обновления windows жутко тормозит макрос
 
Приветствую всех гуру и не гуру excel - подскажите, пожалуйста, можно ли решить эту проблему без отката обновлений офиса и виндовс?
Кратко по ситуации: макрос исправно работал несколько лет, обсчитывал 40000 строк за 2 минуты. После обновления (возможно, виндовс, возможно, офис) ту же задачу обсчитывает примерно за два часа. Работает без ошибок. Конфигурация системы: виндовс 10, офис 2019, процессор Raizen 5. Ускорение отключением обновления экрана и т.п. практически не помогает. При анализе работы макроса выяснилось, что макрос стартует бодро, но сильно замедляется в процессе работы. Повторюсь, макрос старый, то есть ошибки в коде исключены. Тормозить начал с неделю назад.
И второй вопрос, неоднократно отмечено, что при прерывании работы некоторых макросов комбинацией ctrl + break все макросы начинают тормозить или перестают работать. Помогает перезагрузка ОС. Готов предположить, что перезагрузка очищает память ошибок макросов (не знаю правильный термин) - подскажите как очистить память ошибок программно или вручную? Возможно это чем-то поможет и в решении первой проблемы.
Найти первую ячейку в столбце, имеющую границы
 
Коллеги, помогите новичку советом:
Кратко:
  • имеем столбец на странице, верхние ячейки которого могут быть заполнены, но не принадлежат таблице
  • ячейки, расположенные ниже, могут быть пустыми или заполненными и принадлежат таблице (имеют границы)
  • задача - найти первую строку таблицы (самую верхнюю ячейку с границами)
Такая идея не помогла
Код
For tb = 1 To 10
    If Cells(tb, 2).Borders.LineStyle = True Then
        MsgBox "Cells(tb, 1).address= " & Cells(tb, 1).address
    End If
Next tb
Ускорить копирование/сложения диапазонов, расположенных на разных страницах
 
Прошу не ругать новичка за, вероятно, простейший вопрос)

Код, указанный ниже, копирует диапазон с одной страницы и прибавляет его данные к диапазону на другой странице. Макрос работает долго (40000 строк в отчете), подозреваю, что это происходит из-за того, что макрос прыгает по страницам. Application.ScreenUpdating уже использую. Можно ли переписать макрос так, чтобы он не выделял данные на соседних страницах, а просто их копировал?
Код
        Sheets("Ассортимент").Select
        Range(Cells(i, 8, Cells(i, 237)).Select
        Selection.Copy
        Sheets("Шахматка").Select
        Cells(LastRow + 1, 5).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
            :=False, Transpose:=False
Буду признателен за любой совет.
Нужен макрос переносящий все столбцы таблицы в первый столбец или в новый столбец
 
Буду признателен всем кто откликнется - подскажите как решить задачу макросом. Вводные такие: есть таблица с произвольным количеством столбцов и строк. В таблице имеется много пустых ячеек и строк (с текстовой информацией). Необходимо все столбцы таблицы перенести в первый столбец (выстроить столбцы один под другой). Либо в новый столбец. И затем удалить пустые строки в этом столбце.
Преобразовать значение ячейки в число
 
Уважаемые специалисты, подскажите какой-нибудь макрос, который позволит преобразовать значение ячейки в число. Макрекордер не помог решить эту задачу.
Пример: было так 0018 и пометка "число сохранено как текст" - нужно сделать так 18. Макрос нужен для активной ячейки, но идеально сделать для диапазона К17:К5000
Спасибо всем, кто откликнется.
Изменено: vikttur - 02.09.2021 11:43:04
Скрытие строк таблицы, если хотя бы одна ячейка не закрашена зеленым цветом
 
Пример таблицы во вложении - нужны скрыть строки, в которых нет ни одной зеленой ячейки . Макросы не желательны - хотелось бы решить вопрос функциями.
Заполнение ячеек в строках, скрытых фильтром
 
Уважаемые гуру экселя, подскажите как доработать указанный ниже макрос, чтобы он заполнял не только видимые ячейки, но и ячейки в скрытых строках (скрыты фильтром).
Код
Проплаты.Cells(a1.Row, 17).Value = ДатаПогашения
Настраиваемая сортировка таблицы, необходимо подсказать решение для настройки сортировки с учетом промежуточных сумм
 
Кратко по задаче (см. файл с примером - страница "исходные"): в столбце D содержится перечень клиентов, в столбце В указан код, обозначающий принадлежность клиента к холдингу, в теле таблицы указаны суммы заказов
Задача: отсортировать таблицу, например по столбцу AQ по порядке убывания сумм заказов холдингов (см. страницу "как нужно"). То есть первые три строки должен занимать холдинг 134, так как у этого холдинга самый большой оборот (9 400 922 руб.). В таблицу нельзя добавлять новые строки или столбцы.
Если стандартных инструментов для такой сортировки в экселе нет, то просьба предложить макрос - хотя бы часть кода.
Изменено: VIZ_VIZ - 18.08.2020 13:06:12
макрос для парсинга Яндекса и пр. (сбор названий сайтов по ключевому слову), необходим макрос. который позволит по произвольному поисковому запросу заполнять таблицу url-ами с выдачи Яндекса
 
Необходим макрос, который бы через Яндекс/Google собирал адреса сайтов в таблицу. Примерный механизм работы: пользователь нажимает кнопку макроса - вводит ключевое слово (запрос для Яндекса), макрос самостоятельно открывает браузер, вводит запрос в поиск и затем собирает все сайты, которые нашел Яндекс в таблицу excel. Поиск можно ограничить 10 страницами выдачи. На данный момент интересует стоимость и сроки разработки такого макроса.
Возможное продолжение разработки - доработка макроса под сбор всех контактных данный по найденным url.
Макрос для сбора названий сайтов по ключевому слову, макрос по поиску сайтов по конкретной тематике
 
Просьба подсказать новичку существует ли техническая возможность по созданию макроса, который бы через Яндекс собирал адреса сайтов в таблицу. Конкретнее: пользователь нажимает кнопку макроса - вводит ключевое слово (запрос для Яндекса), макрос самостоятельно открывает браузер, вводит запрос в поиск и затем собирает все сайты, которые нашел Яндекс в таблицу excel. Поиск можно ограничить 10 страницами выдачи. Было бы замечательно увидеть любую часть кода такого макроса, например код для открытия браузера и размещения запроса в яндексе. Ничего похожего на данном ресурсе не нашел, если что-то пропустил - поделитесь ссылкой, пожалуйста.
Доработать макрос с формулой суммы диапазона для работы с переменным диапазоном
 
Привет специалистам, подскажите новичку как доработать макрос, подставляющий формулу суммы в ячейку. Имеем рабочий макрос:
Код
.Cells(3, clmn + 1).FormulaR1C1 = "=SUM(RC[-12]:RC[-1])"
Начало диапазона определяется переменной FP, а конец clmn. Нужно доработать указанный макрос - вместо конкретных значений RC[-12] и RC[-1] подставить эти переменные. Как это можно сделать? Буду признателен всем, кто откликнется.
Макрос не видит данные в сжатом столбце
 
Приветствую специалистов и не только! Вот код, который прекрасно работает, когда ширина столбца с данными позволяет отобразить данные целиком
Код
Me.ListBox1.List(i, 8 = Cells(stroka, 27).Value 'номер УПД
Если сузить столбец (у пользователя маленький монитор), то макрос не видит данные, которые в нем содержатся. Предполагаю, что, если скрыть столбец, то макрос тем более ничего не увидит. Уверен, что в vba есть стандартные функции, позволяющие читать данные из скрытых или узких столбцов. Подскажите такие функции или поделитесь примером кода.
Спасибо всем, кто поможет новичку))
порядок вывода формы VBA и диалогового окна, нужен совет как поменять порядок вывода окна формы и диалогового окна
 
Приветствую специалисты! Прошу подсказать новичку как в ниже указанном макросе сделать, чтобы окно формы VBA открывалось после окончания работы диалогового окна (сейчас все открывается с точность до наоборот - сначала открывается форма и только потом диалоговое окно).
спасибо всем, кто откликнется.
Код
Private Sub ф_Добавить_Комментарий_Initialize()
    CommandButton1_Click
End Sub

Private Sub CommandButton1_Click()
Dim komment
flag = False
komment = ф_Добавить_Комментарий.TextBox1.Text
Unload ф_Добавить_Комментарий

    With Sheets("Ассортимент")
        Set selectRange = Application.InputBox("Выберите клиента", "Номер Позиции", Type:=8) '''''''''Речь про этот диалог
        n_1 = Cells(selectRange.Row, 1).Text ' номер менеджера
        n_2 = Cells(selectRange.Row, 2).Text ' номер клиента
    End With

    With Sheets("База клиентов")
        Set bk_act = .Cells.Find("Акты", , xlFormulas, xlWhole) ' ячейка с комментарием
        Set bk_n_1 = .Cells.Find("№1", , xlFormulas, xlWhole) ' ячейка с №1
        Set bk_n_2 = .Cells.Find("№2", , xlFormulas, xlWhole) ' ячейка с №2
        Set bk_find = bk_n_2.EntireColumn.Find(n_2, LookIn:=xlValues)
        If Not bk_find Is Nothing Then
            firstAddress = bk_find.Address
            Do
                If .Cells(bk_find.Row, bk_n_1.Column).Text = n_1 Then
                        flag = True
                    .Cells(bk_find.Row, bk_act.Column).Value = .Cells(bk_find.Row, bk_act.Column).Text + "  " + komment
                    If OptionButton2 = True Then
                        .Cells(bk_find.Row, bk_act.Column).Interior.Color = RGB(255, 0, 0)
                    End If
                    MsgBox "Комментарий добавлен!"
                Else
                    Set bk_find = bk_n_2.EntireColumn.FindNext(bk_find)
                End If
            Loop While Not bk_find Is Nothing And bk_find.Address <> firstAddress And flag = False
        End If
        If flag = False Then
            MsgBox "Клиент не найден в базе клиентов или активен фильтр"
        End If
    End With
End Sub
Если важно, то форма вызывается отдельным макросом.
Код
Sub Добавить_Комментарий()
    ф_Добавить_Комментарий.Show vbModeless
End Sub
можно ли использовать метод Find для поиска по нескольким параметрам?, нужно найти информацию в таблице по двум ключевым столбцам - можно ли для этого использовать метод Find?
 
Коллеги, в VBA не силен, поэтому идея с Find может быть глупой... Find привлек значительно более высокими скоростями поиска по сравнению с другими методами (например, с поиском в цикле, используя If).
Задача: имеем таблицу, в которой первый и второй столбец содержат уникальный цифровой ключ клиента (ключ состоит из двух частей), необходимо выбрать определенного клиента. Необходимо иметь в виду, что "половинки" ключа не уникальны - могут быть одинаковыми у разных клиентов - то есть нужно искать клиента именно по полному ключу). Если такая возможность для Find существует, то прошу поделиться примером кода.
Для наглядности предлагаю считать, что две переменные (половинки) ключа нам известны:  Nm - код №1, а Nkl - код №2.
Если кому-то пригодиться, то вот оригинальный устаревший код, который искал информацию ориентируясь только на половинку кода - именно его я и адаптирую под текущую потребность.
Код
Set old_base_act = old_wb.sheets("База клиентов").Colomns(1).Find(what:=old_wsh.Cells(oCell.Row,2).value, Lookat:=xlWhole, Lookin:=xlFormulas)
Здесь old_wsh.Cells(oCell.Row,2).value - это переменная Nkl, Nm можно найти аналогично
Если Find не умеет искать по двум параметрам, то прошу подсказать другие быстрые методы (про СУММАМН для VBA знаю, именно ее и планирую использовать как запасной вариант, но, думаю, что Find будет быстрее).
Спасибо всем, кто откликнется.
[ Закрыто] сломался макрос - не могу найти ошибку, макрос исправно работает на всех компьютерах, кроме одного - просьба помочь найти или отключить ошибку
 
Проблема такая: макрос начал указывать не верную информацию в столбце 28 на листе "Проплаты" - вместо нужно информации заносит в ячейку такое сообщение: =T(IFERROR(VLOOKUP(--MID(RC[-24],2,SEARCH("_",RC[-24])-2),Отгрузка!R2C5:R23880C40,36,0),""))
Просьба помочь найти ошибку или подсказать как отключить занесение данной информации в таблицу (как временное решение поможет)
Код макроса ниже:
Код
Option Explicit

Sub ПреобразованиеДеловые()
    Dim lrow, mdel_date, motgr_date
        
    With Sheets("Деловые")
        lrow = .Cells(.Rows.Count, 4).End(xlUp).Row
        
        '16
        .Range(.Cells(2, 16), .Cells(lrow, 16)).FormulaR1C1 = "=DATEVALUE(MID(RC[-14],1,10))"
        .Range(.Cells(2, 16), .Cells(lrow, 16)).Value = .Range(.Cells(2, 16), .Cells(lrow, 16)).Value

        '17
        .Range(.Cells(2, 17), .Cells(lrow, 17)).FormulaR1C1 = "=VALUE(RC[-8])"
        .Range(.Cells(2, 17), .Cells(lrow, 17)).Value = .Range(.Cells(2, 17), .Cells(lrow, 17)).Value
        
    End With
    
    mdel_date = WorksheetFunction.Max(Sheets("Деловые").Columns(16))
    motgr_date = WorksheetFunction.Max(Sheets("Отгрузка").Columns(32))
    
    If mdel_date > motgr_date Then
        MsgBox "Добавьте данные во вкладку Отгрузка"
        Exit Sub
    End If
    
    If mdel_date < motgr_date Then
        MsgBox "Добавьте данные во вкладку Деловые"
        Exit Sub
    End If
    

    With Sheets("Проплаты")
        
        lrow = .Cells(.Rows.Count, 4).End(xlUp).Row
        
        '22
        .Range(.Cells(2, 22), .Cells(lrow, 22)).FormulaR1C1 = _
            "=IF(ISNA(LOOKUP(2,1/((Деловые!R2C17:R27319C17=RC[-1])*(Деловые!R2C16:R27319C16=RC[-15])),Деловые!R2C4:R27319C4)),"""",LOOKUP(2,1/((Деловые!R2C17:R27319C17=RC[-1])*(Деловые!R2C16:R27319C16=RC[-15])),Деловые!R2C4:R27319C4))"
        .Range(.Cells(2, 22), .Cells(lrow, 22)).Value = .Range(.Cells(2, 22), .Cells(lrow, 22)).Value
        
        '23
        .Range(.Cells(2, 23), .Cells(lrow, 23)).FormulaR1C1 = _
            "=IF(ISNA(INDEX(Деловые!R2C14:Деловые!R21175C14,MATCH(RC[-1],Деловые!R2C4:Деловые!R21175C4,0),1)),"""",INDEX(Деловые!R2C14:Деловые!R21175C14,MATCH(RC[-1],Деловые!R2C4:Деловые!R21175C4,0),1))"
        .Range(.Cells(2, 23), .Cells(lrow, 23)).Value = .Range(.Cells(2, 23), .Cells(lrow, 23)).Value
        
        '24
        .Range(.Cells(2, 24), .Cells(lrow, 24)).FormulaR1C1 = _
            "=IF(ISNA(INDEX(Деловые!R2C12:Деловые!R21175C12,MATCH(RC[-2],Деловые!R2C4:Деловые!R21175C4,0),1)),"""",INDEX(Деловые!R2C12:Деловые!R21175C12,MATCH(RC[-2],Деловые!R2C4:Деловые!R21175C4,0),1))"
        .Range(.Cells(2, 24), .Cells(lrow, 24)).Value = .Range(.Cells(2, 24), .Cells(lrow, 24)).Value
        
        '25
        .Range(.Cells(2, 25), .Cells(lrow, 25)).FormulaR1C1 = _
            "=IF(ISNA(INDEX(Деловые!R2C11:Деловые!R21175C11,MATCH(RC[-3],Деловые!R2C4:Деловые!R21175C4,0),1)),"""",INDEX(Деловые!R2C11:Деловые!R21175C11,MATCH(RC[-3],Деловые!R2C4:Деловые!R21175C4,0),1))"
        .Range(.Cells(2, 25), .Cells(lrow, 25)).Value = .Range(.Cells(2, 25), .Cells(lrow, 25)).Value
    
    
        '26
        .Range(.Cells(2, 26), .Cells(lrow, 26)).FormulaR1C1 = "=--MID(RC[-22],2,FIND(""_"",RC[-22])-2)"
        .Range(.Cells(2, 26), .Cells(lrow, 26)).Value = .Range(.Cells(2, 26), .Cells(lrow, 26)).Value
        
        
        '27
        .Range(.Cells(2, 27), .Cells(lrow, 27)).FormulaR1C1 = _
            "=IF(ISNA(LOOKUP(2,1/((Отгрузка!R2C41:R28190C41=RC[3])*(Отгрузка!R2C5:R28190C5=RC[-1])),Отгрузка!R2C39:R28190C39)),"""",LOOKUP(2,1/((Отгрузка!R2C41:R28190C41=RC[3])*(Отгрузка!R2C5:R28190C5=RC[-1])),Отгрузка!R2C39:R28190C39))"
        .Range(.Cells(2, 27), .Cells(lrow, 27)).Value = .Range(.Cells(2, 27), .Cells(lrow, 27)).Value
        
        '28   - ВЕРОЯТНО ОШИБКА ЗДЕСЬ
        .Range(.Cells(2, 28), .Cells(lrow, 28)).FormulaR1C1 = _
            "=T(IFERROR(VLOOKUP(--MID(RC[-24],2,SEARCH(""_"",RC[-24])-2),Отгрузка!R2C5:R23880C40,36,0),""""))"
        .Range(.Cells(2, 28), .Cells(lrow, 28)).Value = .Range(.Cells(2, 28), .Cells(lrow, 28)).Value
        
        '29
        .Range(.Cells(2, 29), .Cells(lrow, 29)).FormulaR1C1 = _
            "=IF(ISNA(INDEX(Отгрузка!R2C41:Отгрузка!R21890C41,MATCH(RC[-2],Отгрузка!R2C40:Отгрузка!R21890C39,0),1)),"""",INDEX(Отгрузка!R2C41:Отгрузка!R21890C41,MATCH(RC[-2],Отгрузка!R2C40:Отгрузка!R21890C39,0),1))"
        .Range(.Cells(2, 29), .Cells(lrow, 29)).Value = .Range(.Cells(2, 29), .Cells(lrow, 29)).Value
    
    End With
  
End Sub
Вставить формулу в ячейку макросом
 
есть такая формула, по мере добавления строк в таблице (добавляются определенным макросом), нужно дописывать эту формулу в соответствующую ячейку. Подскажите как это сделать? Спасибо все, кто откликнется
=СУММЕСЛИМН($F$2:$F$1616;$A$2:$A$1616;A510;$B$2:$B$1616;B510;$C$2:$C$1616;C510;$G$2:$G$1616;">0")-СУММЕСЛИМН($K$2:$K$1616;$A$2:$A$1616;A510;$B$2:$B$1616;B510;$C$2:$C$1616;C510)

Есть вторая формула, с ней, наверное, справлюсь по аналогии:
=M510-N510
ошибка type mismatch в операторе If
 
код такой:
Код
If Range("J1").Offset(i, 0) > -10 Then
такой код тоже не работает
Код
If Range("J1").Offset(i, 0).Value > -10 Then
в этом столбце стоят отрицательные и положительные числа, формат ячеек числовой. В чем проблема, почему выдает Type mismatch?
Спасибо все, кто откликнется
Макрос спотыкается на #Н/Д
 
Был рабочий код макроса
Код
Sub Обновить_договора()
    lrow = Cells(Rows.Count, 4).End(xlUp).Row
    Range(Cells(2, 8, Cells(lrow, .FormulaR1C1 = "=LOOKUP(2,1/((Договора!R2C17:R10001C17=RC[23])*" & _
        "(Договора!R2C16:R10001C16=""Да"")),Договора!R2C1:R10001C1)"
    Range(Cells(2, 8, Cells(lrow, 8.Value = Range(Cells(2, 8, Cells(lrow, 8)).Value    
    MsgBox "Выполнено!"
End Sub
макрос обращается на соседнюю страницу "Договора" и заносит в текущую таблицу нужные данные. Если данных на соседней странице не нашлось (ячейка оказалась пустой), то макрос заносит в таблицу сообщение #Н/Д

внесли доработку - перед MsgBox добавили следующий код:
Код
   If Range(Cells(2, 8, Cells(lrow, 8.Value = "#Н/Д" Then
        MsgBox "#Н/Д найдено"
        Range(Cells(2, 1), Cells(lrow, 1)).Font.Color = RGB(255, 0, 0)
    End If

в итоге имеем ошибку - Type Mismatch (спотыкается на строке If)

Подскажите где у нас ошибка или как можно изменить макрос, чтобы обойти эту проблему?

макрос для экспорта/импорта всех макросов из файла, Нужен макрос для экспорта/импорта всех макросов, содержащихся в файле одновременно
 
Кратко по ситуации: имеется файл, содержащий очень много макросов (модулей и форм), иногда данный файл ломается и приходится его восстанавливать, в том числе загружать копии макросов вручную (каждый модуль в отдельности). Может кто-то подсказать, есть ли возможность экспортировать или импортировать все макросы одновременно?
Спасибо всем кто откликнется и поможет новичкам!
Макрос ошибается при записи сокращенной даты, вместо августа 2019 выводит сентябрь 2019
 
Коллеги, помогите найти ошибку в макросе. Макрос анализирует таблицу с выставленными счетами и выводит сообщение с краткой датой счета. В периоде с января 2019 по июль 2019 все ОК, а вот вместо августа макрос выдает сентябрь. Формат даты в исходнике не менялся - одинаковый по всей таблице. Самостоятельно ошибку найти не получилось - может кто-то помочь самоучкам?
Код
Sub Учебный2()
Dim i, K, NumSchet, Nm, Nk, Nf, status, f As Integer
Dim StartDate, j, sd As Date
Dim LastRow As Long
Dim NameKl As String
Dim ts
StartDate = #1/1/2019# ' Дата начала анализа
K = 4
For j = StartDate To DateAdd("m", 1, Date)
Range("A1").Offset(1, K).Value = Month(j) & " " & DatePart("yyyy", j)
    MsgBox "Искомая дата " & Range("A1").Offset(1, K).Value
    j = DateAdd("m", 1, j)
    K = K + 1
Next j
End Sub
Изменено: VIZ_VIZ - 13.08.2019 16:13:59 (исправил код макроса)
Как копировать страницу excell без кнопок пользователя
 
Уважаемые профессионалы, макрос написан макрекордером, мои познания в макросах минимальны - прошу не судить строго. Буду признателен за любой совет, например за название функции, которую можно применить в данном случае. Суть проблемы указана в описании.

Макрос копирует таблицу exell (целую страницу) в другой файл, при этом копирует страницу вместе с кнопками пользователя, находящимися в первой строке таблицы.  Просьба подсказать можно ли настроить исключение, чтобы данные кнопки не копировались?
Код
Sub Перенос_базы() 
    Sheets("База клиентов").Select
    Columns("A:J").Select
    Selection.Copy
    Windows("Текущие оплаты.xlsm").Activate
    Sheets("База клиентов").Select
    Columns("A:J").Select
    ActiveSheet.Paste
    Range("K12").Select
    Sheets("Проплаты").Select
    Range("D5").End(xlDown).Offset(1, 0).Select
    
    
    Windows("Ассортимент.xlsm").Activate
    Sheets("База клиентов").Select
    Range("K12").Select
    Application.CutCopyMode = False
    Sheets("Ассортимент").Select
    Range("D5").End(xlDown).Offset(1, 0).Select
End Sub
Таблица по клиентским счетам. Макрос периодически ошибается с номером месяца
 
Макрос анализирует выставленные клиентам счета  и формирует их в отдельную таблицу. При этом в первой декаде текущего месяца периодически глючит - в данном примере август путает с сентябрем. В дальнейшем вместо сентября он поставит август и все будет ОК.П
Чтобы избежать лишних вопросов выкладываю полный код макроса. На странице с данными (Ассортимент) дата счета указана в отдельной колонке и выглядит так: 13.08.19
Код
Sub Динамика2()
'
' Динамика Макрос
Dim i, K, NumSchet, Nm, Nk, Nf, status, f As Integer
Dim StartDate, j, sd As Date
Dim LastRow As Long
Dim NameKl As String
Dim ts
Sheets("Динамика").Cells.Clear
StartDate = #1/1/2017# ' дата начала анализа

'заполняем шапку таблицы ============================================
Range("A2").Value = "№1"
Range("B2").Value = "№2"
Range("C2").Value = "№3"
Range("D2").Value = "название"
Range("A2:D2").Borders.LineStyle = True
Range("A2:D2").Font.Bold = True
K = 4
For j = StartDate To DateAdd("m", 1, Date)
    Range("A1").Offset(1, K).Value = MonthName(DatePart("m", j)) & " " & DatePart("yyyy", j)
    Range("A1").Offset(1, K).Borders.LineStyle = True
    Range("A1").Offset(1, K).Font.Bold = True
    Range("A1").Offset(1, K).EntireColumn.AutoFit
    Range("A1").Offset(1, K).Interior.ColorIndex = 15
    j = DateAdd("m", 1, j)
    K = K + 1
Next j
'шапка заполнена =================================================================

NumSchet = Range(Worksheets("Ассортимент").Range("A101"), Worksheets("Ассортимент").Range("A101").End(xlDown)).Rows.Count
 For i = 101 To NumSchet 'указан диапазон счетов для анализа

'получаем данные из "Ассортимента" ===============================================        
    With Worksheets("Ассортимент")
        Set cell_address = .Cells.Find(what:="Статус заказа")
        status = cell_address.Column ' получаем номер столбца со статусом заказа
    End With
    If Worksheets("Ассортимент").Range("A1").Offset(i, status - 1) = 1 Then 'счет отгружен
        NameKl = Worksheets("Ассортимент").Range("A1").Offset(i, 3) 'название клиента/счета
        sd = Worksheets("Ассортимент").Range("A1").Offset(i, 4)
        If sd >= StartDate Then ' выполнено обязательное условие - дата счета больше стартовой даты
        Data_Scheta = MonthName(DatePart("m", Worksheets("Ассортимент").Range("A1").Offset(i, 4))) & " " & DatePart("yyyy", Worksheets("Ассортимент").Range("A1").Offset(i, 4)) 'получаем дату счета
        Nm = Worksheets("Ассортимент").Range("A1").Offset(i, 0) 'получаем номер менеджера
        Nk = Worksheets("Ассортимент").Range("A1").Offset(i, 1) 'получаем номер клиента
        Nf = Worksheets("Ассортимент").Range("A1").Offset(i, 2) 'получаем номер фирмы клиента
        If Len(NameKl) < 11 Then
            MsgBox "Слишком короткое название счета: " & Nm & " " & Nk & " " & Nf & " " & NameKl ' предупреждение о коротких названиях
            Else
                NameKl = Right(NameKl, Len(NameKl) - 11)
        End If
        SummScheta = Worksheets("Ассортимент").Range("A1").Offset(i, 5) 'получаем сумму счета
  
'начинаем заполнять таблицу =======================================================
            LastRow = Cells(Rows.Count, 1).End(xlUp).Row
          ' разносятся счета по уже занесенным клиентам
            For f = 2 To LastRow
                   If Range("A1").Offset(f, 0).Value = Nm And Range("B1").Offset(f, 0).Value = Nk And Range("C1").Offset(f, 0).Value = Nf Then
                        K = 4
                        For j = StartDate To DateAdd("m", 1, Date)
                            If Data_Scheta = Range("A1").Offset(1, K) Then
                                Range("A1").Offset(f, K).Value = Range("A1").Offset(f, K).Value + SummScheta
                                Range("A1").Offset(f, K).NumberFormat = "#,##0"
                                Range("A1").Offset(f, K).Borders.LineStyle = True
                            End If
                            j = DateAdd("m", 1, j)
                            K = K + 1
                        Next j
                        GoTo NextSchet
                   End If
            Next f
        ' разносятся счета по новым клиентам
          Range("A1").Offset(LastRow, 0).Value = Nm
          Range("A1").Offset(LastRow, 0).Borders.LineStyle = True
          Range("B1").Offset(LastRow, 0).Value = Nk
          Range("B1").Offset(LastRow, 0).Borders.LineStyle = True
          Range("B1").Offset(LastRow, 0).NumberFormat = "###" 
          Range("C1").Offset(LastRow, 0).Value = Nf
          Range("C1").Offset(LastRow, 0).Borders.LineStyle = True
          Range("D1").Offset(LastRow, 0).Value = NameKl
          Range("D1").Offset(LastRow, 0).Borders.LineStyle = True
          Range("A1").Offset(LastRow, 0).Rows.AutoFit
          K = 4
          For j = StartDate To Date Step 0
              If Data_Scheta = Range("A1").Offset(1, K) Then
                Range("A1").Offset(LastRow, K).Value = Range("A1").Offset(LastRow, K).Value + SummScheta
                Range("A1").Offset(LastRow, K).NumberFormat = "#,##0"
                Range("A1").Offset(LastRow, K).Borders.LineStyle = True
                Else
                  Range("A1").Offset(LastRow, K).Borders.LineStyle = True
              End If
              j = DateAdd("m", 1, j)
              K = K + 1
          Next j
          f = 0
            Else
         '   MsgBox "счет " & NameKl & " не входит в выбранный диапазон"
        End If
    End If
NextSchet:
 Next i
ActiveSheet.Range("A2", Range("A2").Offset(LastRow - 2, K - 1)).Sort [B:B], xlAscending, , , , , , xlYes
End Sub
Изменено: VIZ_VIZ - 13.08.2019 09:22:47
ошибка при вызове макроса из макроса, при вызове макроса процедурой Call выходит ошибка Ambiguous name detected: Преобразование_Проплаты
 
Кратко по ситуации: в работающий макрос добавили вызов другого макроса из этой же книги - Call название макроса. На всех компьютерах  обновление прошло успешно - все работает. У меня выходит ошибка Ambiguous name detected: Преобразование_Проплаты (Преобразование_Проплаты - это название макроса, который должен быть вызван).
Названия макросов и модулей проверил - ошибок нет, одноименных тоже нет. По отдельности макросы работают прекрасно. В чем может быть проблема - подскажите, пожалуйста.
Макросы не прикладываю  - длинные - вряд ли кому-то будет интересно.
подскажите как открыть/обратиться к файлу excel из outlook и подсчитать кол-во заполненных строк таблицы, подскажите как исправить код макроса
 
такой код не работает
NumKl = Range(objXls.Worksheets("База клиентов (2)").Range("A1"), objXls.Worksheets("База клиентов (2)").Range("A1").End(xlDown)).Rows.Count
выдает ошибку: "Sub or Function not defined" (вероятно outlook не понимает. что такое range)
Буду признателен за любой совет

В рамках благодарности готов выложить полный код макроса, который делает дубликаты писем outlook и рассылает их клиентам по файлу excel (рассылка осуществляется партиями, с определенных учетных записей, с задержкой по времени)
Изменено: VIZ_VIZ - 30.05.2019 11:46:02
[ Закрыто] прошу совет по макросу, чем заменить range (адаптирую макрос из excel в outlook)
 
Приветствую специалистов. Вопрос, вероятно, смешной, но я не программист - буду признателен за совет. Переношу макрос из Excel  в outlook - не работает ниже указанная строка. Выяснил, что range в oulook не работает. Кто-нибудь подскажет как его можно заменить?

Нужно заменить такую строку:

NumKl = Range(objXls.Worksheets("База клиентов (2)").Range("A1"), objXls.Worksheets("База клиентов (2)").Range("A1").End(xlDown)).Rows.Count

NumKl  - это количество заполненных строк в таблице файла Excel  (это значение нужно знать для запуска цикла For  to  - см. ниже по тексту)


Пробовал обойти проблему так:

Set objXls = GetObject(, "Excel.Application")
   If objXls Is Nothing Then
       Set objXls = CreateObject("Excel.Application")
            objXls.Workbooks.Open "D:\Ассортимент.xlsm"
   End If

   For Each i In objXls.Rows

и т.д.

но такой цикл выполняется бесконечное количество раз.



Цикл For i = 0 To NumKl  работает прекрасно, но нужно как-то вычислить NumKl.

Подскажите. пожалуйста, что я делаю не так, какую функцию можно использовать?
Не учитывать скрытые строки при просмотре таблицы, как настроить цикл просмотра таблицы для просмотра только видимых значений
 
Привет талантам и не только!
Есть макрос, который просматривает таблицу и использует найденные значения. Проблема - макрос учитывает все значения, даже скрытые строки таблицы (автофильтром или вручную). Кто-то может подсказать, как можно просматривать только видимые значения, может быть есть специальная функция или свойство?
вот кусок кода
Код
For i = j To j + 19 ' какой-то цикл
adr = adr + ";" + Worksheets("База клиентов").Range("G1").Offset(i, 0) ' получение данных из таблицы - просматривает даже скрытые строки
Next i
макрос для outlook или Excell - без оплаты, макрос для массовой рассылки писем с интервалом времени - для outlook или Excell
 
Привет талантам!
Задачи для макроса:
  1. обращается к файлу Excell и берет из него электронные адреса (из конкретного столбца таблицы)
  2. создает письма с одинаковой темой и содержанием, прикрепляет или не прикрепляет файл (получится 1000 шт. писем). (один клиент - одно письмо, получателей у клиента может быть несколько - они занесены в excell через точку с запятой). Желательно предусмотреть возможность ввода темы письма и текста письма пользователем через диалоговое окно, например, "введите тему письма".
  3. рассылает эти письма с интервалом времени - в течение рабочего дня (иначе рассылку заспамит почтовый сервер)
ВАЖНО! письма должны уходить не с основной учетной записи outlook, а с заранее настроенной в макросе.

PS Стандартный макрос для Excell с интервалом времени мы использовать не можем - блокирует программу Excell на весь рабочий день. Кстати, если кто-то подскажет как открыть копию Excell в Windows7 - это может нам помочь.

Если поделитесь кодом такого или похожего макроса с дилетантами - будем признательны.

PPS Кусочек кода тоже поможет (формирование писем в папке "исходящие" или установка таймера на готовые письма и т.п.).
Если кто-то готов сделать такой макрос за оплату - сообщите стоимость, пожалуйста. Но бюджета у нас нет......
Доработка макроса, доработка макроса создания писем для Outlook
 
Имеется макрос. который находит адреса электронной почты в указанных строках таблицы excell и создает несколько писем в outlook. Задача: доработать макрос. чтобы создавалось только одно письмо, в котором адреса пользователей будут указываться в разделе скрытая копия (через точку с запятой)
Можно что-то доработать в этом макросе и сколько это может стоить?
Файл с макросом приложен.

файлы не загружаются, можно скачать по ссылкам
https://yadi.sk/d/r5c9b32i3ULUvR
https://yadi.sk/d/IfkULJ0B3ULUvb
Изменено: VIZ_VIZ - 12.04.2018 07:48:55 (добавил файлы)
Автоматическое изменение высоты строк в таблице, При сортировке таблицы высота строк не подстраивается под новое содержимое.
 
Необходимо регулярно сортировать таблицу, в которой строки имеют разную высоту. Проблема в том, что при сортировке высота строк не подстраивается под новое содержимое - часть информации получается либо скрытой, либо остается много лишнего пустого места (ячейка сохраняет размер старого содержимого). Нужен способ решения этой проблемы, например макрос. Кто-то может помочь?

Идеи править "в ручную" - не предлагать!))))  - таблица огромная!

до сортировки https://yadi.sk/i/7rBy2qjj3LDmb2
после сортировки (много пустого места) https://yadi.sk/i/nYi4kaJb3LDmoi
после сортировки (текст не уместился) https://yadi.sk/i/IPcqhbNj3LDmuM
Страницы: 1
Наверх