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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 155 След.
Разбить на разные строки значение, внесённое в одну ячейку., Разделить ячейку
 
Стараюсь прислушиваться, в этот раз что-то пропустил. Вариант названия темы:
Разбить на разные строки значение, внесённое в одну ячейку.
Перейти на нужную строку без горизонтальной прокрутки
 
Код
Sub test()
    myScroll 100, 10
End Sub
Sub myScroll(iRow As Long, iCol As Long)
    Dim ActiveWindow_ScrollColumn As Long
    ActiveWindow_ScrollColumn = ActiveWindow.ScrollColumn
    Cells(iRow, iCol).Select
    ActiveWindow.ScrollColumn = ActiveWindow_ScrollColumn
    ActiveWindow.ScrollRow = iRow
End Sub
Перейти на нужную строку без горизонтальной прокрутки
 
Код
Sub test()
    myScroll 50
End Sub
Sub myScroll(iRow As Long)
    Dim ActiveWindow_ScrollRow As Long
    ActiveWindow_ScrollRow = ActiveWindow.ScrollRow
    Cells(iRow, ActiveCell.Column).Select
    ActiveWindow.ScrollRow = 1
End Sub
Разбить на разные строки значение, внесённое в одну ячейку., Разделить ячейку
 
Код
'v2
Sub SplitSelection()
    Dim rn As Range
    On Error Resume Next
    Set rn = Intersect(Selection.Columns(1), ActiveSheet.UsedRange)
    On Error GoTo 0
    If rn Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim cl As Range
    For Each cl In rn
        SplitCell cl
    Next
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Private Sub SplitCell(cl As Range)
    Dim arr As Variant
    arr = Split(cl.Value, vbLf)
    If IsArray(arr) Then
        Dim brr As Variant
        Dim bb As Variant
        For Each bb In arr
            If bb <> "" Then
                If IsEmpty(brr) Then
                    ReDim brr(0 To 0)
                Else
                    ReDim Preserve brr(0 To UBound(brr) + 1)
                End If
                brr(UBound(brr)) = bb
            End If
        Next
        If Not IsEmpty(brr) Then
            If UBound(brr) > LBound(brr) Then
                cl.Cells(2, 1).Resize(UBound(brr) - LBound(brr)).EntireRow.Insert
                cl.Cells(1, 1).Resize(UBound(brr) - LBound(brr) + 1) = Application.Transpose(arr)
            End If
        End If
    End If
End Sub

Изменено: МатросНаЗебре - 12.08.2022 15:25:37
Выпадающий список с условием, Создание выпадающего списка с условием в рядом стоящей ячейке.
 
Вариант макросом.
Код
'v2
Sub SetValidation()
    SetSheetValidation Sheets("Лист1")
End Sub

Sub SetSheetValidation(sh As Worksheet)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    InitValidation dic, Sheets("СПИСОК Поставщиков")

    Dim cl As Range
    For Each cl In sh.UsedRange.Columns(2).Cells
        SetCellValidation cl, dic
    Next
End Sub

Private Sub InitValidation(dic As Object, sh As Worksheet)
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    dicY.CompareMode = 1
    
    Dim dicN As Object
    Set dicN = CreateObject("Scripting.Dictionary")
    dicN.CompareMode = 1
    Dim dicI As Object
    
    
    With sh
        Dim yy As Long
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim arr As Variant
        arr = .Cells(1, 1).Resize(yy, 2)
    End With
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
            If Not dicY.Exists(arr(yy, 1)) Then
                dicY.Item(arr(yy, 1)) = yy
                Set dicN.Item(arr(yy, 1)) = CreateObject("Scripting.Dictionary")
            End If
            dicN.Item(arr(yy, 1)).Item(arr(yy, 2)) = 0
        End If
    Next
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim sValidation As String
    Dim vv As Variant
    For Each vv In dicY.Keys()
        yy = dicY.Item(vv)
        Set dicI = dicN.Item(vv)
        With sh.Cells(yy, 4).Resize(1, dicI.Count)
            .Value = dicI.Keys()
            sValidation = "='" & sh.Name & "'!" & .Address(1, 1)
        End With
        dic.Item(arr(yy, 1)) = sValidation
    Next

    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

Private Sub SetCellValidation(cl As Range, dic As Object)
    With cl.Cells(1, 2).Validation
        .Delete
        If dic.Exists(cl.Value) Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=dic.Item(cl.Value)
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = False
            .ShowError = True
        End If
    End With
End Sub
Изменено: МатросНаЗебре - 12.08.2022 10:59:28
Запускать макрос при изменении значения ячейки
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
    Case "B2"
        Dim arr As Variant
        arr = Range("I2:L2")
         
        Dim xx As Long
        xx = Cells(3, Columns.Count).End(xlToLeft).Column + 1
        xx = Application.Max(xx, [N1].Column)
         
        Application.EnableEvents = False
        Cells(2, xx).Value = Range("A2").Value
        Cells(3, xx).Resize(UBound(arr, 2), 1) = Application.Transpose(arr)
        Application.EnableEvents = True
    End Select
End Sub
Выбор значения по диагонали
 
Код
=ИНДЕКС(Б2!B2:BG30;ПОИСКПОЗ(G35;Б2!A2:A30;1)+(ПОИСКПОЗ(H35;Б2!A2:A30;1)-ПОИСКПОЗ(G35;Б2!A2:A30;1));ПОИСКПОЗ(G34;Б2!B1:BG1;1)-(ПОИСКПОЗ(H35;Б2!A2:A30;1)-ПОИСКПОЗ(G35;Б2!A2:A30;1)))
=ИНДЕКС(Б2!B2:BG30;ПОИСКПОЗ(G35;Б2!A2:A30;1)+(ПОИСКПОЗ(I35;Б2!A2:A30;1)-ПОИСКПОЗ(G35;Б2!A2:A30;1));ПОИСКПОЗ(G34;Б2!B1:BG1;1)-(ПОИСКПОЗ(I35;Б2!A2:A30;1)-ПОИСКПОЗ(G35;Б2!A2:A30;1)))
...ли
Изменено: МатросНаЗебре - 09.08.2022 15:39:38
Создание файла txt с наименованием из ячейки и копирование в него данных по условию
 
Код
Sub SaveTextFile()
    Const sPath = "D:\Test"

    Dim sName As String
    sName = Range("C3").Value
    
    Dim yy As Long
    yy = Application.Max(Cells(Rows.Count, [D1].Column).End(xlUp).Row, Cells(Rows.Count, [E1].Column).End(xlUp).Row, 6)
    Dim arr As Variant
    arr = Range(Cells(6, 4), Cells(yy, 5))
    Dim txt As String
    For yy = 1 To UBound(arr, 1)
        txt = txt & arr(yy, 1) & vbTab & arr(yy, 2) & vbCrLf
    Next
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(sPath) Then fso.CreateFolder sPath & "\"
    With fso.CreateTextFile(sPath & "\" & sName & ".txt", True)
        .Write txt
        .Close
    End With
End Sub
Запускать макрос при изменении значения ячейки
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
    Case "B2"
        Dim arr As Variant
        arr = Range("I2:L2")
        
        Dim xx As Long
        xx = Cells(3, Columns.Count).End(xlToLeft).Column + 1
        xx = Application.Max(xx, [N1].Column)
        
        Cells(3, xx).Resize(UBound(arr, 2), 1) = Application.Transpose(arr)
    End Select
End Sub
Как сделать выборку из диапазона?
 
Код
G2    =МАКС((Поставщики[Артикул]=F2)*(Поставщики[Дата]=H2)*Поставщики[Цена поставщика])
H2    =МАКС((Поставщики[Артикул]=F2)*Поставщики[Дата])
Вводить как формулы массива.
Копирование данных из открытого файла при непостоянном имени, Как скопировать данные из определенного листа и определенных ячеек открытого файла в другой?
 
Код
ActiveCell.FormulaR1C1 = "='[" & Workbooks(2).Name & "]Sales plan'!R34C4"
Обработка тестовой формы для испытания образцов, Три макроса для оператора формы
 
Пишу в личку.
Сделал. Оплату получил.
Изменено: МатросНаЗебре - 10.08.2022 17:11:02
Линия тренда для части графика
 
И ещё вариант. С помощью функции ЛИНЕЙН получаете коэффициенты для последних 30 записей. Получаете значения с помощью этих коэффициентов, на них строите график.
Последовательное копирование выделенного блока с формулами, Неполное копирование выделенного блока с формулами
 
Код
C5    =ИНДЕКС(Лист1!A:A;ОТБР((СТРОКА()-4)/28+2))
Активация макроса при выполнении условия, Активация макроса при введении определенного значения в ячейку.
 
Первая строка макроса
Код
If Range("A1").Value <> "Ок" Then Exit sub
Вывод заполненных позиций на другой лист, Вывести готовое КП на другой лист исходя из данных в ЗАЯВКЕ
 
Код
ЗАЯВКА!R11         =R10+(J11<>"")
ЗАЯВКА!S11:AB11    =ЕСЛИ(F11<>"";F11;S10)
Протянуть. На листе КП проВПРить от нумерации.
Написать значения через запятую в зависимости от условий
 
Если без дополнительных столбцов, то можно так:
Код
=ПСТР(ЕСЛИ(A2="Yes";", "&A$1;"")&ЕСЛИ(B2="Yes";", "&B$1;"")&ЕСЛИ(C2="Yes";", "&C$1;"")&ЕСЛИ(D2="Yes";", "&D$1;"")&ЕСЛИ(E2="Yes";", "&E$1;"")&ЕСЛИ(F2="Yes";", "&F$1;"");3;ДЛСТР(A1&B1&C1&D1&E1&F1)+2*СЧЁТЗ($A$1:$F$1))
Макрос отправки почты
 
Самый стабильный способ: часть таблицы сохранять в html, этот кусок вставлять в письмо.
Менее стабильный вариант, но более стабильный чем #1, выполнять копирование поближе к вставке.
Код
Range("A1:Z100").Copy
DoEvents
Application.SendKeys "^v"
Добавление строк через макрос по нажатию кнопки с сохранением параметров и настроек строки выше в умной таблице
 
Со строкой итогов.
Код
Sub Макрос6()
   With Sheets("ДР").ListObjects("Таблица6")
       .Range.Rows(.Range.Rows.Count).EntireRow.Insert
   End With
End Sub
Добавление строк через макрос по нажатию кнопки с сохранением параметров и настроек строки выше в умной таблице
 
Код
Sub Макрос6()
   With Sheets("ДР").ListObjects("Таблица6")
       .Range.Rows(.Range.Rows.Count + 1).EntireRow.Insert
       .Resize .Range.Resize(.Range.Rows.Count + 1)
       '.ListRows.Add
   End With
End Sub
Добавление строк через макрос по нажатию кнопки с сохранением параметров и настроек строки выше в умной таблице
 
А выложите, пжста, код сюда.
Добавление строк через макрос по нажатию кнопки с сохранением параметров и настроек строки выше в умной таблице
 
При добавлении строки добавьте
Код
.EntireRow
Как с помощью VBA скопировать информацию с одного листа в другой по условию
 
Код соответствующий формуле из примера. Меня несколько смущает, что формула очень далека от формулировки задачи в сообщении #1.
Код
Sub ВыгрузкаСвод()
    Dim srr As Variant
    Dim vrr As Variant
    srr = Sheets("Свод").UsedRange
    vrr = Sheets("Выгрузка").UsedRange
    
    Dim ys As Long
    For ys = 4 To UBound(srr, 1)
        If srr(ys - 1, 1) = "название работ" Then
            If vrr(ys, 7) = "" Then
                srr(ys, 8) = vrr(ys, 1)
            ElseIf vrr(ys, 7) > 0 Then
                srr(ys, 8) = vrr(ys, 2)
            Else
                srr(ys, 8) = "-"
            End If
        End If
    Next
    
    Sheets("Свод").UsedRange = srr
End Sub
Сложный фильтр таблицы
 
Лучше в стандартный, отдельный.
Разобрать текст в ячейке, Разобрать текст в ячейке на составляющие
 
Код
Sub Шматок()
    Dim rr As Range
    On Error Resume Next
    Set rr = Selection.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
        
    Dim cl As Range
    For Each cl In rr
        JobCell cl.Value, cl.Cells(1, 2)
    Next
End Sub
Private Sub JobCell(ByVal cellIn As Variant, cellOut As Range)
    If cellIn = "" Then
        cellOut.ClearContents
    Else
        cellIn = myReplace(cellIn)
    
        Dim arr As Variant
        arr = Split(cellIn, " ")
        cellOut.Resize(1, UBound(arr) - LBound(arr) + 1) = arr
    End If
End Sub
Private Function myReplace(ByVal txt As String) As String
    Dim vv As Variant
    For Each vv In Array("/", ":")
        txt = Replace(txt, vv, " ")
    Next
    myReplace = txt
End Function
Сложный фильтр таблицы
 
Код
Option Explicit

Sub mySort()
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim sh1 As Worksheet
    Set sh1 = ActiveSheet
    sh1.Copy
    Dim sh2 As Worksheet
    Set sh2 = ActiveSheet
    
    Dim yy As Long
    Dim xx As Long
    Dim arr As Variant
    With sh2
        yy = .Cells(.Rows.Count, "F").End(xlUp).Row
        arr = .Range("E1").Resize(yy, 3)
        
        For yy = 3 To UBound(arr, 1)
            Select Case arr(yy, 2)
            Case """Ф"""
                For xx = 1 To UBound(arr, 2)
                    arr(yy, xx) = Empty
                Next
            End Select
        Next
        
        .Range("E1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        
        Dim rr As Range
        Set rr = .Range("E2").Resize(UBound(arr, 1) - 1, UBound(arr, 2))
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=rr.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange rr
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        yy = .Cells(.Rows.Count, "F").End(xlUp).Row
        .Range(.Cells(yy + 1, [E1].Column), .Cells(.Rows.Count, [G1].Column)).Clear
        arr = .Range("E1").Resize(yy, 3)
        
        Dim uu As Long
        For yy = UBound(arr, 1) To 3 Step -1
            uu = WorksheetFunction.Match(arr(yy, 1), sh1.Columns("E:E"), 0)
            .Rows(yy + 1).Insert
            sh1.Cells(uu + 1, 5).Resize(1, 3).Copy .Cells(yy + 1, 5)
        Next
    End With
    
    Application.Calculation = Application_Calculation
End Sub

В названии темы указанно "фильтр", а в условии по факту "сортировка".
Изменено: МатросНаЗебре - 03.08.2022 12:11:48
Подбор необходимой суммы по параметрам в промежутке %, Суммеслимн Подбор необходимой суммы по параметрам в промежутке %
 
Код
=ВПР(;;;1)
Упорядочивание и ведение excel реестра Транспортной компании с возможностью дополнительных расчётов., Необходимо упорядочить ведение реестра грузоперевозок ТК, добавить возможность расчёта: простоев, отставания фактического выполнения рейса от плана.
 
Пишу в личку.
В работе.
Изменено: МатросНаЗебре - 08.08.2022 12:24:24
Вставка строки в конец именованного диапозона, Вставка строки в конец именованного диапозона
 
Код
     Intersect(Rows(.Row + .Rows.Count), .EntireColumn).Insert , CopyOrigin:=xlFormatFromLeftOrAbove

Ячейка, ссылается на ячейку на другом листе. Как получить этот адрес?
 
Если значения в столбце B на Лист1 уникальны, то можно использовать
Код
=ПОИСКПОЗ(C4;Лист1!B:B;0)
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 155 След.
Наверх