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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 148 След.
Сумма произведений из одного столбца по условиям
 
Вариант через UDF
Код
=СУММПРОИЗВ(НЕПУСТЫЕ(H7:J25;1;3);J27:J30)
Код
Function НЕПУСТЫЕ(массив1 As Variant, столбец_непустой As Long, столбец_значение As Long) As Variant
    Dim ar1 As Variant
    Dim ar2 As Variant
    ar1 = массив1
    
    Dim y1 As Long
    Dim y2 As Long
    Dim x1 As Long
    For y1 = 1 To UBound(ar1, 1)
        If Not IsEmpty(ar1(y1, столбец_непустой)) Then
            y2 = y2 + 1
        End If
    Next
    ReDim ar2(1 To y2, 1 To 1)
    y2 = 0
    
    For y1 = 1 To UBound(ar1, 1)
        If Not IsEmpty(ar1(y1, столбец_непустой)) Then
            y2 = y2 + 1
            ar2(y2, 1) = ar1(y1, столбец_значение)
        End If
    Next
    НЕПУСТЫЕ = ar2
End Function
Не работает условное форматирование
 
Код
=И(ЗНАЧЕН(E$1)>=$C2;ЗНАЧЕН(E$1)<=$D2)
Игнорирование макроса открытия книги., Как пропустить макрос, который срабатывает при открытии книги.
 
Код
Application.EnableEvents = false
или открывайте с зажатым Shift-oм.
Проверка данных при копировании данных макросом с одного листа на другой
 
Цитата
написал:
подозреваю проверки одной ячейки будет не достаточно.
Цитата
написал:
что то нужно)))
Подозрения развеялись )
Проверка данных при копировании данных макросом с одного листа на другой
 
Код
Sub Add_Sell()
    Dim n As Long
    n = Worksheets("Персональные данные").Range("A100000").End(xlUp).Row
    If Worksheets("Персональные данные").Cells(n, 1).Value <> Worksheets("Ввод данных").Range("A6").Value Then
        Dim arr As Variant
        arr = Worksheets("Ввод данных").Range("G6:P6")
        Worksheets("Персональные данные").Cells(n + 1, 2).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Worksheets("Персональные данные").Cells(n + 1, 1).Value = Worksheets("Ввод данных").Range("A6").Value
        With Worksheets("Движение")
            n = .Range("A100000").End(xlUp).Row
            arr = Range("A6:G6")
            .Cells(n + 1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        End With
    End If
End Sub
Как сохранить значения в памяти, а потом вставить за раз всё
 
Цитата
просто записывать туда значения
Код
    Dim r_calculation As Long
    set r_calculation = calculation.Cells(1, 1).Resize(74, 40)

    For i = 3 To LR
      
        calculation.Range("S49").Value = source.Range("A" & i)
        arr_calculation = r_calculation 


   
Обьеденить файлы с синхронизацией по столбцам
 
Код
Sub CollectFiles()
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim wb1 As Workbook
    Set wb1 = Workbooks.Add(1)
    
    Dim wb2 As Workbook
    Dim vFile As Variant
    For Each vFile In aFiles
        Set wb2 = Workbooks.Open(vFile, False, True)
        CopyWb wb1, wb2
        wb2.Close False
    Next
    wb1.Saved = True
End Sub

Private Sub CopyWb(wb1 As Workbook, wb2 As Workbook)
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    For Each sh2 In wb2.Worksheets
        If sh2.Visible = xlSheetVisible Then
            Select Case sh2.Name
            Case "Инструкция"
            Case Else
                On Error Resume Next
                Set sh1 = wb1.Worksheets(sh2.Name)
                On Error GoTo 0
                If sh1 Is Nothing Then
                    sh2.Copy After:=wb1.Worksheets(wb1.Worksheets.Count)
                Else
                    CopySheets sh1, sh2
                End If
                
                Set sh1 = Nothing
            End Select
        End If
    Next
End Sub

Private Sub CopySheets(sh1 As Worksheet, sh2 As Worksheet)
    Dim arrCopy As Variant
    Dim x2 As Long
    Dim x1 As Long
    Dim y2 As Long
    Dim y1 As Long
    With sh1
        y1 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
    y2 = sh2.UsedRange.Rows.Count
    For x2 = 1 To sh2.UsedRange.Columns.Count
        If Not IsEmpty(sh2.Cells(2, x2).Value) Then
            x1 = 0
            On Error Resume Next
            x1 = WorksheetFunction.Match(sh2.Cells(2, x2).Value, sh1.Rows(2), 0)
            On Error GoTo 0
            If x1 = 0 Then x1 = sh1.UsedRange.Columns.Count + 1
            With sh2
                If y2 = 4 Then
                    ReDim arrCopy(1 To 1, 1 To 1)
                    arrCopy(1, 1) = .Cells(y2, x2).Value
                Else
                    arrCopy = .Range(.Cells(4, x2), .Cells(y2, x2))
                End If
            End With
            sh1.Cells(y1, x1).Resize(UBound(arrCopy, 1), UBound(arrCopy, 2)) = arrCopy
        End If
    Next
End Sub

Private Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 2 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\"
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
        Next
    End With
    ShowFileDialog = arr
End Function
Как сохранить значения в памяти, а потом вставить за раз всё
 
Ещё вариант.
Код
Sub VSP_A2()
 
'
' Удалить Макрос
'
 
    Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
 
    Dim source As Worksheet, calculation As Worksheet, result As Worksheet
    Dim LR As Long, LRR As Long
     
    Set source = ThisWorkbook.Sheets("Усилия")
    Set calculation = ThisWorkbook.Sheets("Проверка")
    Set result = ThisWorkbook.Sheets("Выносливость")
     
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    LR = source.Columns("A").Find("END", Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious).Row
         
    Dim arr_result As Variant
    ReDim arr_result(1 To LR - 2, 1 To 6)
    
    Dim arr_calculation As Variant
    
    Dim i As Long
    For i = 3 To LR
     
        calculation.Range("S49").Value = source.Range("A" & i)
        arr_calculation = calculation.Cells(1, 1).Resize(74, 40)
         
        arr_result(i - 2, 1) = arr_calculation(49, 19)
        arr_result(i - 2, 2) = arr_calculation(50, 37)
        arr_result(i - 2, 3) = arr_calculation(65, 40)
        arr_result(i - 2, 4) = arr_calculation(68, 40)
        arr_result(i - 2, 5) = arr_calculation(71, 40)
        arr_result(i - 2, 6) = arr_calculation(74, 40)
     
    Next
    
    result.Cells(Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(UBound(arr_result, 1), UBound(arr_result, 2)) = arr_result
     
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
 
End Sub
Запуск макроса
 
Код
Sub Переключатель()
    Static ii As Byte
    
    Select Case ii
    Case 0: Macro1
    Case 1: Macro2
    End Select
    
    ii = 1 - ii
End Sub

Sub Macro1()
    MsgBox 1
End Sub
Sub Macro2()
    MsgBox 2
End Sub

Вариант названия темы
Поочерёдный запуск разных макросов одной кнопкой
Изменено: МатросНаЗебре - 24.05.2022 12:58:58
Копирование на скрытый лист при помощи макроса, Проблема при копировании как только делаешь лист скрытым
 
Код
Sub Макрос3()
 
    Dim lVisible As Long
    lVisible = Sheets("АРХИВ").Visible
    Sheets("АРХИВ").Visible = -1
 
    Sheets("АРХИВ").Select
    Rows("1:10").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Sheets("Добавить").Select
     
    Range("AI1:AL9").Select
    Selection.Copy
    Sheets("АРХИВ").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
     
    Sheets("Добавить").Select
     
    Sheets("АРХИВ").Visible = lVisible
End Sub
Формула по расчету процента премии, Нужно написать или усовершенствовать существующую формулу по расчету процента премии
 
Не нашлось желающих иметь отношение к задаче "уменьшим премию, потому что работал в праздничные дни".
Выделить ячейки с двумя значениями в сводной таблице
 
Файл, увы, не скачивается.
Код
=СЧЁТЕСЛИМН(A:A;A:A)

Можно или в отдельный столбец, или в условное форматирование.
Добавление определение валюты к числу в финансовом формате в ячейке в зависимости от значения в другой ячейке
 
Вариант макросом. Вставьте код в модуль листа.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Column <> 2 Then Exit Sub
    
    With Target.Cells(1, 7)
        Select Case Target.Value
        Case "Ruble": .NumberFormat = "_-[$" & ChrW(8381) & "-419] * #,##0.00_-;-[$" & ChrW(8381) & "-419] * #,##0.00_-;_-[$" & ChrW(8381) & "-419] * ""-""??_-;_-@_-"
        Case "Euro": .NumberFormat = "_-[$€-2] * #,##0.00_-;-[$€-2] * #,##0.00_-;_-[$€-2] * ""-""??_-;_-@_-"
        Case "Dollar": .NumberFormat = "_-[$$-409]* #,##0.00_ ;_-[$$-409]* -#,##0.00 ;_-[$$-409]* ""-""??_ ;_-@_ "
        End Select
    End With
End Sub
Пернос значений из таблицы в таблицу по содержанию других ячеек, Необходим перенос данных в список из одной таблицы в другую
 
Вариант формулами
Код
D4:D27        =C4&"#"&СЧЁТЕСЛИМН($C$1:C4;C4)
F4:J12        =ЕСЛИОШИБКА(ИНДЕКС($B$4:$B$27;ПОИСКПОЗ(F$3&"#"&СТРОКА(F1);$D$4:$D$27;0));"")
Условие СЧЕТЕСЛИМН, спасите, помогите)
 
Не исключено, что дело в стиле ссылок.
Код
=СЧЁТЕСЛИМН(R1C60:R567C60;"нет";R1C1:R567C1;">="&ДАТА(2022;5;21);R1C1:R567C1;"<"&ДАТА(2022;5;21)+1)
Формула определения названия вкладки из другой ячейки, Необходимо для работы ВПР в другой вкладке, брать название вкладки из столбца который каждый месяц будет меняться, в одинарный апостроф не получается поставить формулу.
 
Вы в одном гугле от ответа.
Код
=ВПР(R[-2]C;ДВССЫЛ("'"&RC[-8]&"'!R30C1:R178C34";0);15;1)
Условие СЧЕТЕСЛИМН, спасите, помогите)
 
Тогда так
Код
=СЧЁТЕСЛИМН($BH$1:$BH$567;"нет";$A$1:$A$567;">="&ДАТА(2022;5;21);$A$1:$A$567;"<"&ДАТА(2022;5;21)+1)
Формула определения названия вкладки из другой ячейки, Необходимо для работы ВПР в другой вкладке, брать название вкладки из столбца который каждый месяц будет меняться, в одинарный апостроф не получается поставить формулу.
 
Код
=ВПР(K2;ДВССЫЛ("'"&C4&"'!$A$30:$AH$178");15;1)
Условие СЧЕТЕСЛИМН, спасите, помогите)
 
Код
=СЧЁТЕСЛИМН(BH:BH;"нет";A:A;">="&ДАТА(2022;5;21);A:A;"<"&ДАТА(2022;5;21)+1)
Какая формула здесь зашифрована? (задача на проценты в таблице эксель), нужно понять как перенести эту таблицу в эксель, чтобы значение считалось автоматически
 
Для сохранения той же прибыли количество надо увеличить согласно формуле
Код
=ЕСЛИОШИБКА(ЕСЛИ(P$3/(P$3-$O5)>0;100*(P$3/(P$3-$O5)-1);"");"")
или
=ЕСЛИОШИБКА(ЕСЛИ(R3C/(R3C-RC15)>0;100*(R3C/(R3C-RC15)-1);"");"")

По условию части слова в ячейке вставить текст
 
Код
=ЕСЛИ(ПСТР(A2;3;3)="TW-";"TWEEN";ЕСЛИ(ПСТР(A2;3;3)="Sor";"SORTS";ЕСЛИ(ПСТР(A2;3;3)="Mar";"MARIO";"кочерга")))
Если магазинов много, лучше сделать вспомогательную табличку, краткое и полное наименование.
Перемещение листов в книге, Перемещение листов согласно их имени
 
Код
Sub Sortirovka_listov()
  Dim ws As Worksheet, rg As Range, n&, a, c&
  ReDim a(1 To 1)
  For Each ws In Worksheets
    n = n + 1: ReDim Preserve a(1 To n): a(n) = ws.Name
  Next
  With Worksheets(1)
    c = .UsedRange.Column + .UsedRange.Columns.Count
    Set rg = .Cells(1, c).Resize(n, 1): rg = WorksheetFunction.Transpose(a)
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=rg, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rg: .Header = xlNo: .MatchCase = False
        .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    End With
  End With
  a = rg: rg.ClearContents
  For n = 1 To n - 1
    Worksheets(a(n, 1)).Move Before:=Worksheets(n)
  Next
End Sub

Сохранить диапазон в новый файл.
 
Ігор Гончаренко, там ещё форматы ячеек нужны.
Сохранить диапазон в новый файл.
 
Код
Private Sub CommandButton1_Click()
    RangeCopy Range("B3:D5")
End Sub

Private Sub CommandButton2_Click()
    RangeCopy Selection
End Sub

Private Sub RangeCopy(rn As Range)
    Dim FileN$, wb As Workbook
    FileN = ThisWorkbook.Path & "\" & "Test_" & Range("B1") & ".xlsm"
    
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1).Cells(1, 1).Resize(rn.Rows.Count, rn.Columns.Count)
        rn.Copy .Cells(1)
        If rn.Rows.Count = 1 And rn.Columns.Count Then
            .Value = .Value
        Else
            Dim arr As Variant
            arr = .Value
            .Value = arr
        End If
    End With
    
    On Error Resume Next
    Kill FileN
    On Error GoTo 0
    wb.SaveAs FileN, 52
    wb.Close False
    
'    ThisWorkbook.SaveCopyAs FileN
'    Set wb = Workbooks.Open(FileN)
'    ActiveSheet.DrawingObjects.Delete    'oaaeaiea anao eiiiie
'    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
'    ActiveSheet.Copy
'    wb.Close SaveChanges:=False
'    Kill FileN
'    Mid(FileN, Len(FileN), 1) = "x"
'    ActiveWorkbook.SaveAs FileN, 51
'    ActiveWorkbook.Close SaveChanges:=False
    MsgBox "Oaeouee eeno nio?aiai a iiaie eieaa" & FileN
End Sub
Суммирование из диапазона по заданному критерию
 
Код
=СУММЕСЛИМН(4:4;$3:$3;$8:$8)
Код
формула массива
=СУММ(($B9=$B$4:$B$5)*(C$8=$C$3:$K$3)*$C$4:$K$5)
Изменено: МатросНаЗебре - 20.05.2022 13:12:16
автоматически связать ячейки из разных таблиц с одним комментарием
 
В порядке убывания вероятности ошибки.
Есть ли код на листе каталог?
Вносите код на листе отчет в столбец С?
Вносите в одну ячейку?
Включены ли макросы?
Перенос строк в самый вверх, под заголовки, по значению в ячейке
 
Для увеличения автоматизации ), вставьте код в модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns("F:G")) Is Nothing Then
         ПеренестиОплачено
    End If
End Sub
Перенос строк в самый вверх, под заголовки, по значению в ячейке
 
Код
Sub ПеренестиОплачено()
    Const opla = "оплачено"

    Dim tb As ListObject
    Set tb = ActiveSheet.ListObjects(1)
    
    Dim aFormulaIn As Variant
    Dim aFormulaOu As Variant
    aFormulaIn = tb.DataBodyRange.Formula
    ReDim aFormulaOu(1 To UBound(aFormulaIn, 1), 1 To UBound(aFormulaIn, 2))
    
    Dim aStatus As Variant
    aStatus = tb.ListColumns("статус").DataBodyRange.Value
    
    Dim flag As Long
    Dim flagstaff As Long
    Dim xx As Long
    Dim yin As Long
    Dim you As Long
    
    you = you + 1
    For xx = 1 To UBound(aFormulaIn, 2)
        aFormulaOu(you, xx) = aFormulaIn(1, xx)
    Next
    For flagstaff = -1 To 0
        For yin = 2 To UBound(aStatus, 1)
            flag = (aStatus(yin, 1) = opla)
            If flag = flagstaff Then
                you = you + 1
                aFormulaOu(you, 1) = you - 1
                For xx = 2 To UBound(aFormulaIn, 2)
                    aFormulaOu(you, xx) = aFormulaIn(yin, xx)
                Next
            End If
        Next
    Next
    
    Application.EnableEvents = False
    tb.DataBodyRange.Formula = aFormulaOu
    Application.EnableEvents = True
End Sub
Изменено: МатросНаЗебре - 20.05.2022 12:06:05 (Application.EnableEvents)
автоматически связать ячейки из разных таблиц с одним комментарием
 
Вариант макросом. Вставьте код в модуль листа отчет
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Column <> 3 Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
    Dim yCat As Long
    On Error Resume Next
    yCat = WorksheetFunction.Match(Target.Value, Sheets("каталог").Columns(2), 0)
    On Error GoTo 0
    If yCat > 0 Then
        Application.EnableEvents = False
        Sheets("каталог").Cells(yCat, 2).Copy Target
        Application.EnableEvents = False
    End If
End Sub
Поиск наименьшего числа с последующими вычислениями, Поиск наименьшего числа с последующими вычислениями
 
Код
T7:V22        =AA7+AD7+AG7
AA7:AC22      =(G7=ЕСЛИОШИБКА(НАИМЕНЬШИЙ($G7:$I7;1);0))*МИН($C7;--D7)
AD7:AF22      =(G7=ЕСЛИОШИБКА(НАИМЕНЬШИЙ($G7:$I7;2);0))*МИН($C7-СУММ($AA7:$AC7);--D7)
AG7:AI22      =(G7=ЕСЛИОШИБКА(НАИМЕНЬШИЙ($G7:$I7;3);0))*МИН($C7-СУММ($AA7:$AF7);--D7)
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 148 След.
Наверх