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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 213 След.
Расстановка сроков по диапазону значений
 
Код
AA15:AV15    =ЕСЛИ($B$2>=D15;$B$2-D15;$B$2)
C2           =ИНДЕКС(D14:Y14;ПОИСКПОЗ(МИН(AA15:AV15);AA15:AV15;0))

Вариант с дополнительными вычислениями.
Как правильно сослаться на переменную
 
Код
Const myColumnName = "Moy_UID"
Оператор Const (VBA) | Microsoft Learn
Изменено: МатросНаЗебре - 18.03.2024 09:05:23
Подстановка формул в столбец в зависимости от условия в соседнем столбце через макрос
 
Код
'v2
Sub FillFormulas()
    FillFormulasRange Range("AK5:AK37"), Range("CD5:CD37"), Range("CG5:CH9")
End Sub

Private Sub FillFormulasRange(rTarget As Range, rCondition As Range, rDictionary As Range)
    Dim dic As Object
    Set dic = GetDic(rDictionary)
    
    Dim aTrg As Variant
    Dim aCon As Variant
    aCon = rCondition.Value
    ReDim aTrg(1 To UBound(aCon, 1), 1 To 1)
    
    Dim yc As Long
    For yc = 1 To UBound(aCon, 1)
        If dic.Exists(aCon(yc, 1)) Then
            aTrg(yc, 1) = dic.Item(aCon(yc, 1))
        End If
    Next
    
    rTarget.Cells(1, 1).Resize(UBound(aTrg, 1), 1).FormulaR1C1 = aTrg
End Sub

Private Function GetDic(rr As Range) As Object
    Dim arr As Variant
    arr = rr.Columns(1).Resize(, 2).FormulaR1C1
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
'    Dim ya As Long
'    For ya = 1 To UBound(arr, 1)
'        dic.Item(arr(ya, 1)) = arr(ya, 2)
'        Debug.Print "dic.Item(""" & arr(ya, 1) & """) = """ & arr(ya, 2) & """"
'
'    Next
    
    dic.Item("Формула1") = "=1+2"
    dic.Item("Формула2") = "=2+5"
    dic.Item("Формула3") = "=1+6"
    dic.Item("Формула4") = "=8-3"
    dic.Item("Формула5") = "=7-5"
    
    Set GetDic = dic
End Function
Подстановка формул в столбец в зависимости от условия в соседнем столбце через макрос
 
Код
Sub FillFormulas()
    FillFormulasRange Range("AK5:AK37"), Range("CD5:CD37"), Range("CG5:CH9")
End Sub

Private Sub FillFormulasRange(rTarget As Range, rCondition As Range, rDictionary As Range)
    Dim dic As Object
    Set dic = GetDic(rDictionary)
    
    Dim aTrg As Variant
    Dim aCon As Variant
    aCon = rCondition.Value
    ReDim aTrg(1 To UBound(aCon, 1), 1 To 1)
    
    Dim yc As Long
    For yc = 1 To UBound(aCon, 1)
        If dic.Exists(aCon(yc, 1)) Then
            aTrg(yc, 1) = dic.Item(aCon(yc, 1))
        End If
    Next
    
    rTarget.Cells(1, 1).Resize(UBound(aTrg, 1), 1).FormulaR1C1 = aTrg
End Sub

Private Function GetDic(rr As Range) As Object
    Dim arr As Variant
    arr = rr.Columns(1).Resize(, 2).FormulaR1C1
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        dic.Item(arr(ya, 1)) = arr(ya, 2)
    Next
    Set GetDic = dic
End Function
Cбор данных с разных листов и последовательная вставка в столбцы (макрос)
 
Код
Sub CollectDataFromAllSheets()
    'v2
    Dim ws As Worksheet

    Set wbCurrent = ActiveWorkbook
    Workbooks.Add
    Set wbReport = ActiveWorkbook
     
    'копируем на итоговый лист шапку таблицы из первого листа
    'wbCurrent.Worksheets(1).Range("A3").Copy Destination:=wbReport.Worksheets(1).Range("A1")
     
    'проходим в цикле по всем листам исходного файла
    For Each ws In wbCurrent.Worksheets
     
        'определяем номер последней строки на текущем листе и на листе сборки
        n = wbReport.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
         
        'задаем исходный диапазон, который надо скопировать с каждого листа
        Set rngData = ws.Range("A3")          'фиксированный диапазон
           
           
        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, "A")
         
        
        Set rngData = ws.Range("U19")        'область, в ячейке U19
        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, "B")
 
         
    Next ws
    
'    'копируем на итоговый лист шапку таблицы из первого листа
'    'wbCurrent.Worksheets(1).Range("U19").Copy Destination:=wbReport.Worksheets(1).Range("B1")
'
'    'проходим в цикле по всем листам исходного файла
'     For Each ws In wbCurrent.Worksheets
'
'        'определяем номер последней строки на текущем листе и на листе сборки
'        m = wbReport.Worksheets(1).Range("B1").CurrentRegion.Rows.Count
'
'
'        'задаем исходный диапазон, который надо скопировать с каждого листа
'        Set rngData = ws.Range("U19")        'область, в ячейке U19
'
'
'        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
'        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(m + 1, "B")
'
'
'    Next ws
'
End Sub
Дублирование текста через привязку совпадений между ячейками, Необходимо настроить автоматическое дублирование текста в ячейки ниже по списку на основе совпадения значений параллельного списка
 
Код
=ЕСЛИОШИБКА(ВПР(A3;$A$1:B2;2;0);"")
Выборка из СКУД, Выборка из СКУД по дате и времени начала и окончания рабочего времени
 
Код
Option Explicit

Sub Столбцы_ABC()
    JobRange Range("A:C")
End Sub

Private Sub JobRange(rr As Range)
    CloseEmptyWb
    
    Dim ru As Range
    Set ru = Intersect(rr, rr.Parent.UsedRange)
    Set ru = ru.Columns(1).Resize(, 3)
    
    Dim aru As Variant
    aru = ru.Value
    
    Dim aro As Variant
    aro = GetOutputArray(aru)
    
    PrintArray aro
End Sub

Private Sub PrintArray(arr As Variant)
    With Workbooks.Add(1)
        With .Worksheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Value = arr
                .Columns("C:D").NumberFormat = "hh:mm:ss"
                '.Columns("C:D").NumberFormat = "[$-F400]h:mm:ss AM/PM"
                .EntireColumn.AutoFit
            End With
        End With
    End With
End Sub

Private Function GetOutputArray(arr As Variant) As Variant
    Dim brr As Variant
    brr = GetDicItems(arr)
    arr = Empty
    
    Dim crr As Variant
    crr = TransformArray(brr)
    brr = Empty
    GetOutputArray = crr
End Function

Private Function TransformArray(arr As Variant) As Variant
    Dim brr As Variant
    ReDim brr(1 To UBound(arr) - LBound(arr) + 1, 1 To 4)
    
    Dim ya As Long
    Dim yb As Long
    Dim xb As Long
    For ya = LBound(arr) To UBound(arr)
        yb = yb + 1
        For xb = LBound(brr, 2) To UBound(brr, 2)
            brr(yb, xb) = arr(ya)(xb - 1)
        Next
    Next
    TransformArray = brr
End Function

Private Function GetDicItems(arr As Variant) As Variant
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim brr As Variant
    Dim sKey As String
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 1)) And Not IsEmpty(arr(ya, 2)) And Not IsEmpty(arr(ya, 3)) Then
            If IsDate(arr(ya, 2)) And IsNumeric(arr(ya, 3)) Then
                sKey = arr(ya, 1) & arr(ya, 2)
                If dic.Exists(sKey) Then
                    brr = dic.Item(sKey)
                    If brr(2) > arr(ya, 3) Then brr(2) = arr(ya, 3)
                    If brr(3) < arr(ya, 3) Then brr(3) = arr(ya, 3)
                    dic.Item(sKey) = brr
                Else
                    brr = Array(arr(ya, 1), arr(ya, 2), arr(ya, 3), arr(ya, 3))
                    dic.Item(sKey) = brr
                End If
            End If
        End If
    Next
    GetDicItems = dic.Items()
End Function

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Дублирование текста через привязку совпадений между ячейками, Необходимо настроить автоматическое дублирование текста в ячейки ниже по списку на основе совпадения значений параллельного списка
 
Цитата
написал:
А отдельно создавать документы для примера ... желания не слишком много.
Очевидно, Вы предполагаете, что у кого-то создать пример для решения Вашей задачи желания больше.
Я не настаиваю на создании примера, только констатирую, что вижу в ветке.
Помощь с Outlook (автоматический перенос кнопки и макроса на другой ПК)
 
Попробуйте скопировать файл:
C:\Users\USER\AppData\Roaming\Microsoft\Outlook\VbaProject.OTM
Удаление информации вне рамок
 
Цитата
написал:
так быстро, как будто ждали
Вы ещё не видели, как тут реагируют в ветке Работа )
Переименование папок на основе таблицы
 
Код
'sNewFolderName = "123"
sNewFolderName = Range("A1").Value
Удаление информации вне рамок
 
Код
Sub ClearNonBrderedCellsActiveWorkbook()
    ClearNonBrderedCellsWorkbook ActiveWorkbook
End Sub

Private Sub ClearNonBrderedCellsWorkbook(wb As Workbook)
    Dim Application_Calculation As XlCalculation:    Application_Calculation = Application.Calculation:    Application.Calculation = xlCalculationManual
    
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        ClearNonBrderedCellsSheet sh
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub ClearNonBrderedCellsSheet(sh As Worksheet)
    ClearNonBrderedCellsRange sh.UsedRange
End Sub

Sub ClearNonBrderedCellsSelection()
    ClearNonBrderedCellsRange Selection
End Sub

Private Sub ClearNonBrderedCellsRange(rn As Range)
    Dim Application_Calculation As XlCalculation:    Application_Calculation = Application.Calculation:    Application.Calculation = xlCalculationManual
    
    Dim cl As Range
    For Each cl In rn.Cells
        If Not HasBorders(cl) Then cl.ClearContents
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Function HasBorders(cl As Range) As Boolean
     Dim bd As Border
     For Each bd In cl.Borders
        If bd.LineStyle <> xlNone Then
            HasBorders = True
            Exit For
        End If
     Next
End Function
Отчёт с группировками из базы данных
 
Код
If nRow > 2 Then 

И с заголовком общих итогов.
Скрытый текст
Изменено: МатросНаЗебре - 14.03.2024 12:20:01
Визуализация отрезков
 
Цитата
написал:
если стандартные диаграммы так не умеют
Стандартные диаграммы так умеют. Добавьте в диаграмму 4 ряда, каждый ссылающийся на пары точек.
Задать адрес ячейки в виде переменных номера столбца и номера ячейки
 
Если Вам нужен диапазон таблицы, то можно так:
Код
Set Tabl = Range("Таблица2")
или
Set Tabl = ActiveSheet.ListObjects("Таблица2").DataBodyRange
Изменено: МатросНаЗебре - 13.03.2024 16:07:44
Задать адрес ячейки в виде переменных номера столбца и номера ячейки
 
Код
Set b = Cells(RowsRg1, ColumnsRg2)
Так?
Ячейки заливка или цвет текста в строке при совпадении значения
 
DEL
выше уже есть такое решение


Код
=C6=МИН($C6:$I6)
В формулу условного форматирования.
Изменено: МатросНаЗебре - 13.03.2024 15:27:48
Полностью удалить слово из ячейки, если в нем содержится символ
 
Код
=ЕСЛИОШИБКА(ПОДСТАВИТЬ(ПОДСТАВИТЬ(B2;СЖПРОБЕЛЫ(ПРАВСИМВ(ПОДСТАВИТЬ(ЛЕВСИМВ(B2;НАЙТИ("©";B2));" ";ПОВТОР(" ";100));20));"");"  ";" ");B2)
Всплывающая подсказка по данным со второго листа
 
Считаем, что код в модуль листа Лист1 вы вставили правильно.
Макросы в Excel разрешены. Как включить макросы в Excel 2019 (excelvba.ru)
Переходите в ячейку B3 на Лист1.
Вводите ива, нажимаете Enter.
Курсор уйдёт в B4, кликаете в B3.
В ячейке появляется выпадающий список, стрелка справа.
Всплывающая подсказка по данным со второго листа
 
Правый клик на ярлычке листа.
Исходный текст (В разных версия Excel может называться по-разному, ищите что-то похожее).
Появится редактор кода. Вставьте код с форума.
Протянуть автоматически диапазон в формуле.
 
Вставьте пустой столбец I. Формулы расширьте на этот столбец. Теперь при добавлении столбцов формула сохранит работоспособность.
Всплывающая подсказка по данным со второго листа
 
Вариант для двухтактного ввода. Вводите часть фамилии, жмёте Enter. В ячейке появляется выпадающий список. Выбираете пункт в выпадающем списке.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Column <> 2 Then Exit Sub
    
    If InStr(Target.Value, "#") > 0 Then
        FillRangeSplitText Target
    End If
    
    mySetValidation Target, LCase(Target.Value)
End Sub

Private Sub FillRangeSplitText(Target As Range)
    Dim arr As Variant
    arr = Split(Target.Value, "#")
    Target.Resize(, 2).Value = arr
End Sub

Private Sub mySetValidation(cl As Range, findString As String)
    cl.Validation.Delete
    
    Dim validationFormula As String
    validationFormula = GetValidationFormula(findString)
    If validationFormula <> "" Then
        With cl.Validation
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=validationFormula
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With
    End If
End Sub
    
Private Function GetValidationFormula(findString As String) As String
    Dim arr As Variant
    With Sheets("Лист2")
        arr = Intersect(.UsedRange, .Columns("B:C"))
    End With
    
    Dim brr As Variant
    ReDim brr(0 To 0)
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If InStr(LCase(arr(ya, 1)), findString) > 0 Then
            ReDim Preserve brr(0 To UBound(brr) + 1)
            arr(ya, 1) = myReplace(arr(ya, 1))
            arr(ya, 2) = myReplace(arr(ya, 2))
            brr(UBound(brr)) = Join(Array(arr(ya, 1), arr(ya, 2)), "#")
        End If
    Next
    If UBound(brr) > 0 Then
        GetValidationFormula = Join(brr, ",")
    End If
End Function

Private Function myReplace(vv As Variant) As Variant
    Dim res As Variant
    If InStr(vv, ",") > 0 Then
        res = Replace(vv, ",", " ")
    Else
        res = vv
    End If
    myReplace = res
End Function

Изменено: МатросНаЗебре - 12.03.2024 16:00:53 (ReDim Preserve brr)
суммировать значения тех ячеек которые имеют одинаковые цвета в соседнем столбце на против., суммировать значения тех ячеек которые имеют одинаковые цвета в соседнем столбце на против.
 
Код
'Это в ячейку
=СУММЕСЛИЦВЕТ($G$3:$G$8;$E$3:$E$8;ЦВЕТЯЧЕЙКИ(E3))

'Это в стандартный модуль
Function СУММЕСЛИЦВЕТ(диапазон_суммирования As Range, диапазон_цвета As Range, цвет As Long) As Double
    Dim yy As Long
    Dim nn As Double
    Dim cl As Range
    For yy = 1 To диапазон_цвета.Rows.Count
        If диапазон_цвета.Cells(yy, 1).Interior.Color = цвет Then nn = nn + диапазон_суммирования.Cells(yy, 1).Value
    Next
    СУММЕСЛИЦВЕТ = nn
End Function

Function ЦВЕТЯЧЕЙКИ(ячейка As Range) As Long
    ЦВЕТЯЧЕЙКИ = ячейка.Cells(1).Interior.Color
End Function
[ Закрыто] Сумма прописью
 
Сумма прописью (planetaexcel.ru)
Код
Function СУММАПРОПИСЬЮ(n As Double) As String
 
 Dim Nums1, Nums2, Nums3, Nums4 As Variant
 
 Nums1 = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 Nums2 = Array("", "десять ", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", _
                        "восемьдесят ", "девяносто ")
 Nums3 = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", _
                        "восемьсот ", "девятьсот ")
 Nums4 = Array("", "одна ", "две ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 Nums5 = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", _
                        "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
 
 If n <= 0 Then
   СУММАПРОПИСЬЮ = "ноль"
   Exit Function
 End If
 'разделяем число на разряды, используя вспомогательную функцию Class
 ed = Class(n, 1)
 dec = Class(n, 2)
 sot = Class(n, 3)
 tys = Class(n, 4)
 dectys = Class(n, 5)
 sottys = Class(n, 6)
 mil = Class(n, 7)
 decmil = Class(n, 8)
 
 'проверяем миллионы
 Select Case decmil
   Case 1
     mil_txt = Nums5(mil) & "миллионов "
     GoTo www
   Case 2 To 9
     decmil_txt = Nums2(decmil)
 End Select
 Select Case mil
   Case 1
     mil_txt = Nums1(mil) & "миллион "
   Case 2, 3, 4
     mil_txt = Nums1(mil) & "миллиона "
   Case 5 To 20
     mil_txt = Nums1(mil) & "миллионов "
 End Select
www:
 sottys_txt = Nums3(sottys)
 'проверяем тысячи
 Select Case dectys
   Case 1
     tys_txt = Nums5(tys) & "тысяч "
     GoTo eee
   Case 2 To 9
     dectys_txt = Nums2(dectys)
 End Select
 Select Case tys
   Case 0
     If dectys > 0 Then tys_txt = Nums4(tys) & "тысяч "
   Case 1
     tys_txt = Nums4(tys) & "тысяча "
   Case 2, 3, 4
     tys_txt = Nums4(tys) & "тысячи "
   Case 5 To 9
     tys_txt = Nums4(tys) & "тысяч "
 End Select
 If dectys = 0 And tys = 0 And sottys <> 0 Then sottys_txt = sottys_txt & " тысяч "
eee:
 sot_txt = Nums3(sot)
 'проверяем десятки
 Select Case dec
   Case 1
     ed_txt = Nums5(ed)
     GoTo rrr
   Case 2 To 9
     dec_txt = Nums2(dec)
 End Select
 
 ed_txt = Nums1(ed)
rrr:
 'формируем итоговую строку
 СУММАПРОПИСЬЮ = n & "(" & Trim(decmil_txt & mil_txt & sottys_txt & dectys_txt & tys_txt & sot_txt & dec_txt & ed_txt) & ") руб. " & WorksheetFunction.Text((n - Int(n)) * 100, "00") & " коп."
End Function
 
'вспомогательная функция для выделения из числа разрядов
Private Function Class(M, I)
  Class = Int(Int(M - (10 ^ I) * Int(M / (10 ^ I))) / 10 ^ (I - 1))
End Function
Макрос по поиску незащищенных ячеек
 
Вариация из сообщения #6
Код
Function НЕЗАЩИЩЕННЫЕ_НЕПУСТЫЕ(Диапазон As Range) As Boolean
    Dim rLocked As Range
    Set rLocked = UnLockInRange(Диапазон)
    If Not rLocked Is Nothing Then
        НЕЗАЩИЩЕННЫЕ_НЕПУСТЫЕ = WorksheetFunction.CountA(rLocked) > 0
    End If
End Function

Function UnLockInRange(rg As Range) As Range
  Dim c As Range
  If rg Is Nothing Then Exit Function
  For Each c In rg
    If Not c.Locked Then If UnLockInRange Is Nothing Then Set UnLockInRange = c Else Set UnLockInRange = Union(UnLockInRange, c)
  Next
End Function
Создать книгу внутреннего учета, Книга внутреннего учета для швейной мастерской
 
Цитата
написал:
Если бы вчера такая активность была вокруг сообщения
Выходной как-никак.
Изменено: МатросНаЗебре - 11.03.2024 11:13:22
Увеличение значений последовательного ряда чисел на единицу, с каждой новой строкой, Ряд чисел в одной ячейке, через запятую
 
Код
=ПСТР(A1;НАЙТИ(",";A1)+1;ДЛСТР(A1))&","&СЖПРОБЕЛЫ(ПРАВСИМВ(ПОДСТАВИТЬ(A1;",";ПОВТОР(" ";20));20))+1
Вывод на печать и pdf срезов через checkbox
 
Код
Private Sub UserForm_Initialize()
    On Error Resume Next
    Dim cb As Control
    For Each cb In Me.Controls
        If TypeName(cb) = "CheckBox" Then
            cb.Value = ActiveWorkbook.SlicerCaches("Ñðåç_àäðåñ").SlicerItems(cb.Caption).Selected
        End If
    Next
    On Error GoTo 0
End Sub

Private Sub CheckBox1_Click()
    ActiveWorkbook.SlicerCaches("Ñðåç_àäðåñ").SlicerItems(CheckBox1.Caption).Selected = CheckBox1.Value
End Sub
Private Sub CheckBox2_Click()
    ActiveWorkbook.SlicerCaches("Ñðåç_àäðåñ").SlicerItems(CheckBox2.Caption).Selected = CheckBox2.Value
End Sub
Private Sub CheckBox3_Click()
    ActiveWorkbook.SlicerCaches("Ñðåç_àäðåñ").SlicerItems(CheckBox3.Caption).Selected = CheckBox3.Value
End Sub
Вы не из Польши? ) Бобр! ,,,ва ! Я пердоле!  
Правила условного форматирования в сводной таблице, Пожалуйста, помогите прописать правила условного форматирования
 
Цитата
написал:
могло работать первое правило
Меняйте заливку ячейки, а не цвет шрифта.

Или
Правый клик на сводной таблице - Параметры сводной таблицы - Для пустых ячеек отображать - (Убрать галку)
Изменено: МатросНаЗебре - 07.03.2024 09:53:34
Отправка писем из Excel через Outlook
 
Код
sBody = Join(Array(.Range("C4").Value, .Range("B5").Value, .Range("C5").Value), vbCrLf)
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 213 След.
Наверх