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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 73 След.
Перенос строк с форматированием и формулами конечного файла
 
Код
With ShtZ
    .Rows(2).Copy
    .Rows(last_row_other & ":" & y).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    Dim rf As Range
    On Error Resume Next
        Set rf = .Rows(2).SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    If Not rf Is Nothing Then
        Dim cf As Range
        For Each cf In rf
            .Columns(cf.Column).Rows(last_row_other & ":" & y).Formula = cf.Formula
        Next
    End If
End With
Дополните блок копирования переносом формул
Распределение загрузки отдела по проектам в соответствии с ресурсной возможностью отдела
 
Код
Dim dSrok As Object
Dim dZatr As Object
'
Sub Main()
    Job1_init
    Job2_sort
    Job3
End Sub
'
Sub Job1_init()
    Set dSrok = CreateObject("Scripting.Dictionary")
    Set dZatr = CreateObject("Scripting.Dictionary")
    Dim a As Variant
    a = ActiveSheet.Range("A1:O8")
    Dim y As Long
    Dim x As Integer
    For y = 4 To 8
        x = UBound(a, 2) - 1
        Do
            If Not IsEmpty(a(y, x)) Then Exit Do
            If x = 3 Then Exit Do
            x = x - 1
        Loop
        dSrok(a(y, 2)) = x
        dZatr(a(y, 2)) = CInt(a(y, UBound(a, 2)))
    Next
   
End Sub
'
Sub Job2_sort()
    Dim sh As Worksheet
    Set sh = Worksheets.Add
    With sh
        .Cells(1, 1).Resize(dSrok.Count, 1) = Application.Transpose(dSrok.keys())
        .Cells(1, 2).Resize(dSrok.Count, 1) = Application.Transpose(dSrok.Items())
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Cells(1, 2).Resize(dSrok.Count, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Cells(1, 1).Resize(dSrok.Count, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Cells(1, 1).Resize(dSrok.Count, 2)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        Dim a As Variant
        a = .Cells(1, 1).Resize(dSrok.Count, 2)
    End With
    
    Set dSrok = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 1 To UBound(a, 1)
        dSrok.Item(a(y, 1)) = a(y, 2)
    Next
    Application.DisplayAlerts = False
    sh.Delete
    Application.DisplayAlerts = True
End Sub
'
Sub Job3()
    ActiveSheet.Range("C11:N15").ClearContents
    ActiveSheet.UsedRange.Calculate
    
'    Dim h As Variant
'    h = ActiveSheet.Range("A9:N9")
    
    Dim r As Range
    Set r = ActiveSheet.Range("A11:B15")
    Dim a As Variant
    a = r
    Dim y As Long
    Dim x As Byte
    Dim p As Variant
    Dim zt As Integer
    Dim dt As Integer
    Dim fuckup As Object
    Set fuckup = CreateObject("Scripting.Dictionary")
    
    For Each p In dSrok.keys
        y = 1
        Do
            If p = a(y, 2) Then Exit Do
            y = y + 1
            If y > UBound(a, 1) Then
                MsgBox "Не найден " & p, vbInformation
                Exit Sub
            End If
        Loop
        zt = dZatr.Item(p)
        x = 3
        Do
            dt = Cells(9, x).Value - Cells(10, x).Value
            If dt < 0 Then dt = 0
            dt = Application.Min(dt, zt)
            zt = zt - dt
            If dt > 0 Then Cells(11, 1).Cells(y, x).Value = dt
            
            If zt = 0 Then Exit Do
            x = x + 1
            If x > Range("N1").Column Then
                fuckup.Item(p) = 0
                Exit Do
            End If
        Loop
    Next
    
    If fuckup.Count > 0 Then
        MsgBox "Going to fuckup" & vbCrLf & Join(fuckup.keys(), vbCrLf), vbInformation
    End IfEnd Sub

Пункты 1-4 макросом. Такое можно сделать и формулами.
Распределение загрузки отдела по проектам в соответствии с ресурсной возможностью отдела
 
В смысле, последняя заполненная ячейка и есть требуемый срок завершения проекта.
Как из макроса закрыть все процессы Excel?
 
Код
Sub KillThemAll()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim f As String
    f = ThisWorkbook.Path & "\kill.bat"
    With fso.CreateTextFile(f, True)
        Dim i As Long
        For i = 1 To 10
            .Writeline "taskkill /f /im excel.exe"
        Next
        .Writeline "DEL """ & f & """"
        .Close
    End With
    Shell f, vbHide
End Sub
Изменено: МатросНаЗебре - 21 Фев 2020 14:39:02
Найти максимальное значение для одинаковых имен и присвоить им имя
 
Бывает.
1. Вводить надо как формулу массива. F2 Ctrl+Shift+Enter.
2. Вы ввели другую формулу.
Код
Неправильно   =ЕСЛИ(B2=МАКС(($A$2=$A$2:$A$11)*$B$2:$B$11);"Больше";"Меньше")
Правильно     =ЕСЛИ(B2=МАКС((A2=$A$2:$A$11)*$B$2:$B$11);"Больше";"Меньше")
Перенос строк с форматированием и формулами конечного файла
 
Код
Option ExplicitSub perenosSZ()
  
Dim ShtS As Worksheet
Dim ShtZ As Worksheet
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
Dim rng As Range
Dim retZ As Integer
Dim retS As Integer
  
On Error Resume Next
Set ShtZ = Workbooks("База - ЗАКУПКИ.xlsx").Worksheets("БазаЗакупки")
Set ShtS = Workbooks("База - СНАБЖЕНИЕ.xlsx").Worksheets("БазаСнабжение")
'проверяем открыт ли файл для загрузки данных с всплывающим сообщением о необходимости выполнит действие
    If ShtZ Is Nothing Then
        retZ = MsgBox("ВНИМАНИЕ! Откройте файл База - ЗАКУПКИ.xlsx", vbExclamation + vbOKCancel, "Внимание!!!")
    Exit Sub
    End If
    If ShtS Is Nothing Then
        retS = MsgBox("ВНИМАНИЕ! Откройте файл База - СНАБЖЕНИЕ.xlsx", vbExclamation + vbOKCancel, "Внимание!!!")
    Exit Sub
    End If
On Error GoTo 0
'----------------------
    If ShtZ.AutoFilterMode = True Then ShtZ.Cells.AutoFilter ' отключает все фильтры если они включены
    If ShtS.AutoFilterMode = True Then ShtS.Cells.AutoFilter ' отключает все фильтры если они включены
    ShtZ.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2 'отключает групировку второго уровня "разгруппировать"
    ShtS.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2 'отключает групировку второго уровня "разгруппировать"
    Application.ScreenUpdating = False 'отключаем обновление экрана
    Application.Calculation = xlCalculationManual 'отключаем автоматический пересчёт формул после каждого действия с листом
    Application.EnableEvents = False 'отключаем отслеживание событий
    If Application.ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1 'переключает отображения стиля ссылок "R1C1" --> "A1"
      
    Dim rSelection As Range
    Set rSelection = Selection
      
last_row = ShtS.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "Заключение договора"
Dim a As Variant
With ShtS
    a = .Range(.Cells(1, 1), .Cells(last_row, [au1].Column))
End With
Dim b As Variant
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
Dim y As Long
y = 1
Dim x As Integer
For first_row = last_row To 1 Step -1
    If InStr(1, strg, a(first_row, 32)) > 0 Then 'Условие отбора строк по "статусу заявки""
        For x = 1 To UBound(b, 2)
            b(y, x) = a(first_row, x)
        Next
        y = y + 1
    End If
Next
ShtZ.Cells(last_row_other, 1).Resize(UBound(b, 1), UBound(b, 2)) = b
y = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row
With ShtZ
    .Rows(2).Copy
    .Rows(last_row_other & ":" & y).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
For first_row = last_row To 1 Step -1
    If InStr(1, strg, ShtS.Cells(first_row, 32).Value) > 0 Then 'Условие отбора строк по "статусу заявки""
              
'            ShtZ.Range("A2:AU2").Copy
'            ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'
'            'ShtZ.Range("A2:AU2").Copy ShtZ.Range("A" & last_row_other & ":AU" & last_row_other) 'копируем формат 2-й строки базы закупок и применяем к новым строкам
'            ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).Value = ShtS.Range("A" & first_row & ":AU" & first_row).Value 'вставляет строку соответствующую критериям
        If ShtZ.Range("Y" & last_row_other).Value = "" Then ShtZ.Range("Y" & last_row_other).Value = "С->З " & Date Else ShtZ.Range("Y" & last_row_other).Value = ShtZ.Range("Y" & last_row_other).Value & ", С->З " & Date ' вставляет текущую дату в ячейку Y в строке соответствующую критериям
              
            If Not rng Is Nothing Then 'проверяем создан ли диапазон для накопления строк
                Set rng = Union(rng, ShtS.Rows(first_row)) 'накапливаем в диапазоне строки для удаления
            Else
                Set rng = ShtS.Rows(first_row) 'создаём диапазон для накопления строк для удаления
            End If
              
            last_row_other = last_row_other + 1
    End If
Next
  
If Not rng Is Nothing Then rng.Delete Shift:=xlUp 'удаляем строки в накопленном диапазоне
  
    If ShtZ.AutoFilterMode = False Then ShtZ.Cells.AutoFilter ' включает все фильтра если они отключены
    If ShtS.AutoFilterMode = False Then ShtS.Cells.AutoFilter ' включает все фильтра если они отключены
    ShtZ.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 'включает групировку первого уровня "группировать"
    ShtS.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 'включает групировку первого уровня "группировать"
    
    rSelection.Parent.Parent.Activate
    rSelection.Parent.Select
    rSelection.Select
    
    Application.ScreenUpdating = True 'включаем обновление экрана
    Application.Calculation = xlCalculationAutomatic 'включаем автоматический пересчёт формул после каждого действия с листом
    Application.EnableEvents = True 'включаем отслеживание событий
      
    MsgBox "ВЫПОЛНЕНО!", vbInformation
      
End Sub
Так должно быть получше.
Найти максимальное значение для одинаковых имен и присвоить им имя
 
Код
=ЕСЛИ(B2=МАКС((A2=$A$2:$A$11)*$B$2:$B$11);"Больше";"Меньше")
Формула массива.
Как сформировать ссылку на файл
 
Не будет. На форуме были темы. Что-то вроде "ДВССЫЛ из закрытых файлов", "Динамические ссылки из закрытых файлов".
Как сформировать ссылку на файл
 
Код
=ДВССЫЛ("'C:\tmp\[ФАЙЛ.xlsm]"&A1&"_910'!$D$42")
Перенос строк с форматированием и формулами конечного файла
 
Цитата
Mutarix написал:
остаёться од скачёк после завершения макроса
Чего остаётся?
Прописать Макрос по трансформации даты 27 грудня 2019 року на 27.12.2019, если даты, месяц и год разные по всему столбце
 
Код
=ЕСЛИОШИБКА(ДАТАЗНАЧ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ($F3;" січня ";".01.");" лютня ";".02.");" березня ";".03.");" квiтня ";".04.");" травня ";".05.");" червня ";".06.");" липня ";".07.");" серпня ";".08.");" вересня ";".09.");" жовтня ";".10.");" листопада ";".11.");" грудня ";".12."));F3)
Два столбца в один из разных таблиц
 
Код
Sub Main()
    Dim tb1 As Object: Set tb1 = Sheets("Лист1").ListObjects("Таблица1")
    Dim tb2 As Object: Set tb2 = Sheets("Лист1").ListObjects("Таблица2")
    
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
    Job_tb tb1, d
    Job_tb tb2, d
    Out_tb tb2, d
End Sub
'
Sub Job_tb(tb As Object, d As Object)
    Dim a As Variant
    Dim x As Integer
    a = tb.Range
    For x = 1 To UBound(a, 2)
        If a(1, x) = "Город" Then
            Dim y As Long
            For y = 2 To UBound(a, 1)
                d.Item(a(y, x)) = 0
            Next
            Exit For
        End If
    Next
End Sub
'
Sub Out_tb(tb As Object, d As Object)
    With tb.Range
        .Copy .Offset(0, .Columns.Count + 1)
        .Offset(1, .Columns.Count + 1).Resize(d.Count, 1) = Application.Transpose(d.Keys())
    End With
End Sub
Ну раз можно не совсем про то, что спрашивали, то и я присоединюсь.
Умная таблица с выпадающим списком, которая пополняется.
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    'On Error Resume Next
    If (Cells(2, Target.Column).Value = "Материал") And Target.Cells.Count = 1 Then
        Application.EnableEvents = False
        newVal = Target
        Application.Undo
        oldval = Target
        If Len(oldval) <> 0 And oldval <> newVal Then
            Target = Target & "; " & newVal
        Else
            Target = newVal
        End If
        If Len(newVal) = 0 Then Target.ClearContents
        Application.EnableEvents = True
   ElseIf (Cells(2, Target.Column).Value = "Лаборатория") And Target.Cells.Count = 1 Then
        Application.EnableEvents = False
        newVal = Target
        Application.Undo
        oldval = Target
        If Len(oldval) <> 0 And oldval <> newVal Then
            Target = Target & "," & newVal
        Else
            Target = newVal
        End If
        If Len(newVal) = 0 Then Target.ClearContents
        Application.EnableEvents = True
    End If
End Sub
Может так.
Вывести значения из другой таблицы только для активной строки.
 
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        Client_info Target
    End If
End Sub
'
Sub Client_info(cl As Range)
    Dim sh As Worksheet
    On Error Resume Next
        Set sh = Workbooks("Источник данных.xlsx").Sheets("Лист1")
    On Error GoTo 0
    Dim s As String
    s = Cells(cl.Row, 1).Value
    Columns("E:H").Clear
    Dim y As Long
    On Error Resume Next
        y = WorksheetFunction.Match(s, sh.Columns(1), 0)
    On Error GoTo 0
    If y > 0 Then
        sh.Cells(y, 1).Resize(1, 4).Copy Cells(cl.Row, 5)
    End If
End Sub
В модуль листа.
Распределение загрузки отдела по проектам в соответствии с ресурсной возможностью отдела
 
Представленных данных недостаточно.
Нужны ещё:
- сроки проектов
- мощности отделов.
Изменено: МатросНаЗебре - 21 Фев 2020 09:32:28
Перенос строк с форматированием и формулами конечного файла
 
Вместо
Код
b(y, x) = a(y, x)
Должно быть
Код
 b(y, x) = a(first_row, x)
Макрос для выделения ячеек в другом диапазоне
 
Код
Sub Main()
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    Dim y As Long
    Dim x As Integer
    Dim a As Variant
    
    With Sheets("Лист2")
        a = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
        For y = 2 To UBound(a, 1)
            Set d.Item(a(y, 1)) = CreateObject("Scripting.Dictionary")
        Next
    End With
        
    With Sheets("Лист1")
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column
        a = .Range(.Cells(1, 1), .Cells(y, x))
        Dim v As Variant
        For Each v In d.Keys
            If WorksheetFunction.CountIfs(.Columns(1), v) > 0 Then
                y = WorksheetFunction.Match(v, .Columns(1), 0)
                For x = 2 To UBound(a, 2)
                    If Not IsEmpty(a(y, x)) Then
                        d.Item(v).Item(x) = 0
                    End If
                Next
            End If
        Next
    End With
    
    Dim r As Range
    With Sheets("Лист2")
        For y = 1 To d.Count
            For Each v In d.Items()(y - 1).Keys
                If r Is Nothing Then
                    Set r = Cells(y + 1, v)
                Else
                    Set r = Union(r, Cells(y + 1, v))
                End If
            Next
        Next
        
        .Cells.Interior.Pattern = xlNone
        If Not r Is Nothing Then
            r.Interior.Color = 65535
        End If
    End With
End Sub
Поиск значения через несколько объединенных ячеек
 
Код
=СМЕЩ(R1C1;ПОИСКПОЗ(R113C19;C2;0)-1;ПОИСКПОЗ(R113C22;R1;0)-2+ПОИСКПОЗ(R113C24;СМЕЩ(R1C1;2;ПОИСКПОЗ(R113C22;R1;0)-1;1;4);0))
Дневное задание для производства
 
В прикреплённом файле Ctrl+Shift+Enter не нажимали.
Дневное задание для производства
 
Ctrl+Shift+Enter нажимали?
Дневное задание для производства
 
Код
=ЕСЛИОШИБКА(СМЕЩ('График общий'!$A$1;НАИБОЛЬШИЙ((СМЕЩ('График общий'!$A$6:$A$34;0;ПОИСКПОЗ($B$3;'График общий'!$5:$5;0))>0)*СТРОКА('График общий'!$E$6:$E$34);СТРОКА(1:1))-1;ЕСЛИОШИБКА(ПОИСКПОЗ(A$6;'График общий'!$5:$5;0);ПОИСКПОЗ($B$3;'График общий'!$5:$5;0))-1*(СТОЛБЕЦ()<4));"")
Формула массива. В А7 и протянуть вправо и вниз.
Как отсортировать элементы выпадающего списка по выбранному пользователем значению ячейки?
 
Сложно сказать на каком этапе ошибка. У меня эта формула работает.
Найти все позиции из массива, у которых на определённую дату есть две строки для одного исполнителя, но с разными тарифами.
 
В столбцах D и E надо поработать с форматом. В примерах там текст (хоть и выглядит, как дата), а нужны даты.
Перенос строк с форматированием и формулами конечного файла
 
Код
Option ExplicitSub perenosSZ()
 
Dim ShtS As Worksheet
Dim ShtZ As Worksheet
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
Dim rng As Range
Dim retZ As Integer
Dim retS As Integer
 
On Error Resume Next
Set ShtZ = Workbooks("База - ЗАКУПКИ.xlsx").Worksheets("БазаЗакупки")
Set ShtS = Workbooks("База - СНАБЖЕНИЕ.xlsx").Worksheets("БазаСнабжение")
'проверяем открыт ли файл для загрузки данных с всплывающим сообщением о необходимости выполнит действие
    If ShtZ Is Nothing Then
        retZ = MsgBox("ВНИМАНИЕ! Откройте файл База - ЗАКУПКИ.xlsx", vbExclamation + vbOKCancel, "Внимание!!!")
    Exit Sub
    End If
    If ShtS Is Nothing Then
        retS = MsgBox("ВНИМАНИЕ! Откройте файл База - СНАБЖЕНИЕ.xlsx", vbExclamation + vbOKCancel, "Внимание!!!")
    Exit Sub
    End If
On Error GoTo 0
'----------------------
    If ShtZ.AutoFilterMode = True Then ShtZ.Cells.AutoFilter ' отключает все фильтры если они включены
    If ShtS.AutoFilterMode = True Then ShtS.Cells.AutoFilter ' отключает все фильтры если они включены
    ShtZ.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2 'отключает групировку второго уровня "разгруппировать"
    ShtS.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2 'отключает групировку второго уровня "разгруппировать"
    Application.ScreenUpdating = False 'отключаем обновление экрана
    Application.Calculation = xlCalculationManual 'отключаем автоматический пересчёт формул после каждого действия с листом
    Application.EnableEvents = False 'отключаем отслеживание событий
    If Application.ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1 'переключает отображения стиля ссылок "R1C1" --> "A1"
     
last_row = ShtS.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "Заключение договора"Dim a As Variant
With ShtS
    a = .Range(.Cells(1, 1), .Cells(last_row, [au1].Column))
End With
Dim b As Variant
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
Dim y As Long
y = 1
Dim x As Integer
For first_row = last_row To 1 Step -1
    If InStr(1, strg, a(first_row, 32)) > 0 Then 'Условие отбора строк по "статусу заявки""
        For x = 1 To UBound(b, 2)
            b(y, x) = a(y, x)
        Next
        y = y + 1
    End If
NextShtZ.Cells(last_row_other, 1).Resize(UBound(b, 1), UBound(b, 2)) = b
y = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row
With ShtZ
    .Rows(2).Copy
    .Rows(last_row_other & ":" & y).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End WithFor first_row = last_row To 1 Step -1
    If InStr(1, strg, ShtS.Cells(first_row, 32).Value) > 0 Then 'Условие отбора строк по "статусу заявки""
             
'            ShtZ.Range("A2:AU2").Copy
'            ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'
'            'ShtZ.Range("A2:AU2").Copy ShtZ.Range("A" & last_row_other & ":AU" & last_row_other) 'копируем формат 2-й строки базы закупок и применяем к новым строкам
'            ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).Value = ShtS.Range("A" & first_row & ":AU" & first_row).Value 'вставляет строку соответствующую критериям
        If ShtZ.Range("Y" & last_row_other).Value = "" Then ShtZ.Range("Y" & last_row_other).Value = "С->З " & Date Else ShtZ.Range("Y" & last_row_other).Value = ShtZ.Range("Y" & last_row_other).Value & ", С->З " & Date ' вставляет текущую дату в ячейку Y в строке соответствующую критериям
             
            If Not rng Is Nothing Then 'проверяем создан ли диапазон для накопления строк
                Set rng = Union(rng, ShtS.Rows(first_row)) 'накапливаем в диапазоне строки для удаления
            Else
                Set rng = ShtS.Rows(first_row) 'создаём диапазон для накопления строк для удаления
            End If
             
            last_row_other = last_row_other + 1
    End If
Next
 
If Not rng Is Nothing Then rng.Delete Shift:=xlUp 'удаляем строки в накопленном диапазоне
 
    If ShtZ.AutoFilterMode = False Then ShtZ.Cells.AutoFilter ' включает все фильтра если они отключены
    If ShtS.AutoFilterMode = False Then ShtS.Cells.AutoFilter ' включает все фильтра если они отключены
    ShtZ.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 'включает групировку первого уровня "группировать"
    ShtS.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 'включает групировку первого уровня "группировать"
    Application.ScreenUpdating = True 'включаем обновление экрана
    Application.Calculation = xlCalculationAutomatic 'включаем автоматический пересчёт формул после каждого действия с листом
    Application.EnableEvents = True 'включаем отслеживание событий
     
    MsgBox "ВЫПОЛНЕНО!", vbInformation
     
End Sub
Как-то так. Я переделал только копирование значений и форматов. В условия и код для удаления не лез.
Подбор вариантов комбинации чисел по сумме
 
Код
Sub Перебор()
    Dim a As Variant
    a = Range("A1:A4")
    Dim i1 As Long
    Dim i2 As Long
    Dim i3 As Long
    Dim i4 As Long
    Dim s As String
    For i1 = 0 To 1230 / a(1, 1)
    For i2 = 0 To 1230 / a(1, 1)
    For i3 = 0 To 1230 / a(1, 1)
    For i4 = 0 To 1230 / a(1, 1)
        If a(1, 1) * i1 + a(2, 1) * i2 + a(3, 1) * i3 + a(4, 1) * i4 <= 1230 _
        And a(1, 1) * i1 + a(2, 1) * i2 + a(3, 1) * i3 + a(4, 1) * i4 > 0 Then
            s = ""
            If i1 > 0 Then s = s & "+" & a(1, 1) * i1
            If i2 > 0 Then s = s & "+" & a(2, 1) * i2
            If i3 > 0 Then s = s & "+" & a(3, 1) * i3
            If i4 > 0 Then s = s & "+" & a(4, 1) * i4
            s = Mid(s, 2)
            s = "=" & s
            Debug.Print s
        End If
    Next
    Next
    Next
    Next
End Sub
Автоматическое сокрытие/раскртие столбцов по обновляемому значению
 
Код
Sub CheckNo()
    With Sheets("Main")
        Dim v As Variant
        For Each v In Array("C2", "F2")
            With .Range(v)
                .EntireColumn.Hidden = (.Value = "no")
            End With
        Next
    End With
End Sub
В обычный модуль. Запускается "по кнопке", в смысле не по событию.
Перенос данных из ячеек одного документа в ячейки другого документа c определенным шагом. VBA, Макрос VBA
 
На файлах, которые были в первом сообщении, вроде работает.
Вы не меняли структуру данных? Вроде добавления строк и пр.
Как отсортировать элементы выпадающего списка по выбранному пользователем значению ячейки?
 
Код
=ЕСЛИОШИБКА(СМЕЩ(Таблица1[[#Заголовки];[Столбец3]];НАИБОЛЬШИЙ(($A$2:$A$28=$E$2)*($B$2:$B$28=$F$2)*СТРОКА($A$2:$A$28);СЧЁТЕСЛИМН($A$2:$A$28;$E$2;$B$2:$B$28;$F$2)+1-СТРОКА())-1;0);"")
А это дополнительный столбец для G.
Как отсортировать элементы выпадающего списка по выбранному пользователем значению ячейки?
 
В дополнительный столбец вставить формулу массива:
Код
=ЕСЛИОШИБКА(СМЕЩ(Таблица1[[#Заголовки];[Столбец2]];НАИБОЛЬШИЙ(($A$2:$A$28=$E$2)*СТРОКА($A$2:$A$28);СЧЁТЕСЛИМН($A$2:$A$28;$E$2)+1-СТРОКА())-1;0);"")

В столбце F проверку данных переслать на этот столбец.
Как обращаться из макроса к книгам, открытым в других, параллельных сессиях
 
Код
    Dim objExcel As Variant
    Set objExcel = GetObject("*")
    objExcel.Parent.Visible = True
    objExcel.Parent.WindowState = 1
    objExcel.Activate
Может так.
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 73 След.
Наверх