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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 271 След.
Макрос добаления в умную таблицу пустых строк, Макрос добаления в умную таблицу пустых строк
 
Артур Эдуардович, бех обращения к умной
Код
Sub mrshkei2()
Application.ScreenUpdating = False
Dim i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr - 2 To 6 Step -3
    Rows(i & ":" & i + 3).EntireRow.Insert
Next i
Application.ScreenUpdating = True
End Sub
Изменено: Mershik - 09.12.2021 12:52:44
Не бойтесь совершенства. Вам его не достичь.
как рассортировать макросом значения ориентируясь на таблицу
 
Msi2102, привет, ответы ТСа, что-то похожи на стеб)
Изменено: Mershik - 09.12.2021 12:29:44
Не бойтесь совершенства. Вам его не достичь.
Как удалить из таблицы необходимые строки
 
Din Adiev в данном примере никак
Не бойтесь совершенства. Вам его не достичь.
Как из таблицы с данными выбрать необходимое за определенный период, Пример в теме
 
Цитата
написал:
Необходимо определенные данные из таблицы вытащить за определенный период времени
описали бы логику...
Не бойтесь совершенства. Вам его не достичь.
как рассортировать макросом значения ориентируясь на таблицу
 
Dalm, забанят)
из правил, что запрещено:
Цитата
3.6. Многократно поднимать тему, если на поставленный вопрос ответ не был получен своевременно. В случае многократного поднятия темы сообщениями типа "up", это может быть расценено как флуд.
Изменено: Mershik - 08.12.2021 16:43:57
Не бойтесь совершенства. Вам его не достичь.
как рассортировать макросом значения ориентируясь на таблицу
 
здесь помогают по конкретным вопросам, а с таким подходом
Цитата
Dalm написал:
Это задача по линейному программированию.
Цитата
Dalm написал:
Я это никак не делаю, потому что не знаю как решать эту задачу.Поэтому и задаю вопрос на форуме.
Цитата
Dalm написал:
И нужен макрос чтобы это рассчитать.
вам в раздел РАБОТА - там с оплату кто-то да поможет .
Не бойтесь совершенства. Вам его не достичь.
Замена горизонтального однострочного диапазона на аналогичный по сравнению двух ячеек из этих диапазонов
 
классный приме (нет), у Вас же есть ексель - так сделайте в нем исходные данные и рядом или на другом листе покажите желаемый результат.
Не бойтесь совершенства. Вам его не достичь.
Снятие пароля с блокируемых строк по условию.
 
в модуль листа
Код
Private Sub CommandButton1_Click()
    Call Макрос1
End Sub
Sub Макрос1()
Dim d As Date
Dim a As Variant
Dim i As Integer, lr As Long
d = Format(Now, "DD.MM.YYYY")
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = Range("C1:C" & lr)
On Error Resume Next
For i = 2 To lr
x = DateDiff("D", Sheets("Лист1").Range("C" & i).Value, Date)
     If x > 30 Then
        ActiveSheet.Unprotect Password:="123"
            Sheets("Лист1").Range("A" & i & ":F" & i).Locked = True
            Cells(i, 8) = "Protect"
        Else
            Sheets("Лист1").Range("A" & i & ":F" & i).Locked = False
            Cells(i, 8) = "UNProtect"
        End If
        Next
        ActiveSheet.Protect Password:="123"
        MsgBox "Нельзя менять прошлые периоды"
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    If Target.Column >= 1 And Target.Column <= 6 Then
        Range(Cells(Target.Row, 1), Cells(Target.Row, 6)).Select
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        True
        ActiveSheet.EnableSelection = xlNoRestrictions
    
    End If
End Sub

Sub Макрос3()
    Range("A5:F5").Select
    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        True
    ActiveSheet.EnableSelection = xlNoRestrictions
End Sub

Не бойтесь совершенства. Вам его не достичь.
Снятие пароля с блокируемых строк по условию.
 
, пароль какой?
Не бойтесь совершенства. Вам его не достичь.
Посчитать количество работ поштучно и в метрах в зависимости от значения
 
Цитата
написал:
Посоветуйте что-нибудь?
п.2.3 и 2.4. правил форума советую  
Не бойтесь совершенства. Вам его не достичь.
Найти кто последний сделал продажу
 
, еще вариант на всякий случай если несколько менеджеров было
Код
=ЕСЛИОШИБКА(ИНДЕКС($C$2:$C$15;ПОИСКПОЗ(1;ИНДЕКС((СЧЁТЕСЛИ($H2:H2;$C$2:$C$15)=0)/($D$2:$D$15=$H2);0);0));"")
и еще последний
Код
=ИНДЕКС($C$2:$C$15;АГРЕГАТ(14;6;СТРОКА($C$1:$C$15)/($D$2:$D$15=$H2);1))
Изменено: Mershik - 06.12.2021 17:15:28
Не бойтесь совершенства. Вам его не достичь.
Во множестве формул на страницах книги требуется автозамена
 
Евгений Смирнов,  :D  привет, ну посмотрим че уж там) я же не вижу файла)) вот угадываю) возможно все формулы сделать текстом заменить и когда папка появится вернуть)
Не бойтесь совершенства. Вам его не достичь.
Во множестве формул на страницах книги требуется автозамена
 
Сергей Иванов
Цитата
Следовательно, CTRL+H бессилен в данном случае.
вы пробовали ??

покажите файл - пример - не ваш рабочий файл ( часть где вопроизводится что у Вас не получается, так как я сделал на существующий файл ссылку после чего дополнит к пути еще папку (которой нет) и все заменилось)
Изменено: Mershik - 06.12.2021 14:55:34
Не бойтесь совершенства. Вам его не достичь.
Во множестве формул на страницах книги требуется автозамена
 
раз уже
Цитата
С меня 0,5
CTRL+H - найти "дек_2021" и заменить на "12_2021" - параметры  - убрать галочку с  "ячейка целиком" - искать в книге - заменить все
Изменено: Mershik - 06.12.2021 14:46:21
Не бойтесь совершенства. Вам его не достичь.
Автоподбор высоты строки в объединенных ячейках
 
ну покажите часть ваших ячеек в исходном виде и рядом или на другом листе каким вы видите результат, потому что я вот сделал но уверен вам не подойджет, но есть о чем подумать, удачи
Код
Sub mrshkei()
Dim cell As Range, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
    If Cells(i, 1) <> "" Then
        x = Cells(i, 1).MergeArea.Rows.Count
        Cells(i, 1).Offset(0, 666) = Cells(i, 1)
            With Cells(i, 1).Offset(0, 666)
                .HorizontalAlignment = xlGeneral
                .VerticalAlignment = xlBottom
                .WrapText = True
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            xxx = Columns(1).ColumnWidth
            Columns(666 + 1).ColumnWidth = xxx
            Rows(i & ":" & i).EntireRow.AutoFit
            Rows(i & ":" & i + x - 1).RowHeight = (.RowHeight / x) + 0.5 * x
            Cells(i, 1).Offset(0, 666) = ClearContents
            i = i + x
            End With
    End If
Next i
End Sub
Изменено: Mershik - 06.12.2021 14:41:09
Не бойтесь совершенства. Вам его не достичь.
Автоподбор высоты строки в объединенных ячейках
 
,https://excel2.ru/articles/avtopodbor-v-ms-excel-vysoty-stroki-po-soderzhimomu-pri-obedinenii-yachee...
2 вар например
Изменено: Mershik - 06.12.2021 14:10:37
Не бойтесь совершенства. Вам его не достичь.
как рассортировать макросом значения ориентируясь на таблицу
 
Dalm - еще разок (Последний) попробуем:
сделайте решение как бы вы делали вручную и опишите порядок  действий (расчетов) допустим для 3х позиций...
Не бойтесь совершенства. Вам его не достичь.
как рассортировать макросом значения ориентируясь на таблицу
 
Msi2102  ну а  что -
Цитата
Вот и вся логика
:D  
Не бойтесь совершенства. Вам его не достичь.
как рассортировать макросом значения ориентируясь на таблицу
 
эх когда не знаешь что это Ваеше "линейное программирование" и хотел бы помочь, но логика не описана
Изменено: Mershik - 06.12.2021 08:51:16
Не бойтесь совершенства. Вам его не достичь.
Изменение массива в зависимости от заданного значения ячейки, В титульную таблицу нужно подтягивать данные с других листов (таблицы разноформатные)
 
Andreya Andreya,
Цитата
написал:
не думала, что это можно формулой
можно и не формулой - измените месяц (ДОЛЖЕН БЫТЬ В КНИГЕ)
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("D1")) Is Nothing Then
    Dim sh As Worksheet, lr As Long, lcol As Long, i As Long, n As Long, lr2 As Long
    Set sh = Worksheets(Range("D1").Value)
    With sh
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    lcol = .Cells(1, Columns.Count).End(xlToLeft).Column
    lr2 = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 3 To lr2
    Parf = Cells(i, 1)
    Cod = Cells(i, 2)
        For n = 4 To 6
        Select Case n: Case Is = 4: x = 3: Case Is = 5: x = 4: Case Is = 6: x = 6: End Select ' ВСЕ КАК ЗАВЕЩАЛ ДЖЕК)
            xxx = Mid(Cells(i, 1), 1, InStr(Cells(i, 1), " ") - 1)
            Cells(i, n) = Application.WorksheetFunction.SumIfs(.Range(.Cells(x, 2), .Cells(x, lcol)), _
            .Range(.Cells(2, 2), .Cells(2, lcol)), Cells(i, 2), _
            .Range(.Cells(1, 2), .Cells(1, lcol)), xxx)
        Next n
    Next i
    End With
End If
End Sub
Изменено: Mershik - 05.12.2021 11:02:10
Не бойтесь совершенства. Вам его не достичь.
Изменение массива в зависимости от заданного значения ячейки, В титульную таблицу нужно подтягивать данные с других листов (таблицы разноформатные)
 
, формулой можно так...
Код
=СУММПРОИЗВ((ЛЕВСИМВ($A3;ПОИСК(" ";$A3)-1)=ДВССЫЛ($D$1&"!$B$1:$O$1"))*($B3=ДВССЫЛ($D$1&"!$B$2:$O$2"))*(ДВССЫЛ($D$1&"!$A$3:$A$6")=Итог!D$2)*ДВССЫЛ($D$1&"!$B$3:$O$6"))
Не бойтесь совершенства. Вам его не достичь.
Как правильно перенести данные из массива в комментарий, оптимизация макроса
 
, я бы предпочел смотреть файл-пример с исходными данными и рядом что хотите получитm на выходе

[CODE][/CODE]
Изменено: Mershik - 04.12.2021 20:50:27
Не бойтесь совершенства. Вам его не достичь.
Поиск ячеек со значениями больше ноля и вывод их адресов
 
, запускать с активным 1 листом  не понятрно зачем вам адреса ячеек
Код
Sub mrshkei()
Dim arr, i As Long, lr As Long
lcol = Cells(2, Columns.Count).End(xlToLeft).Column
ReDim arr(1 To 1)
For i = 2 To lcol Step 3
    If Cells(2, i) > 0.01 Then arr(UBound(arr)) = Cells(2, i).Address: ReDim Preserve arr(1 To UBound(arr) + 1)
Next i
Worksheets(2).Range("A1").Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr)
End Sub
Не бойтесь совершенства. Вам его не достичь.
Создать формулы в коде VBA для динамического диапазона и записать их на лист
 
, какой год ставить?  - поставил "никакой")
Код
Sub mrshkei()
Dim arr, arr2, i As Long, lr As Long, col As New Collection
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A2:C" & lr)
For i = LBound(arr) To UBound(arr)
    On Error Resume Next
    col.Add arr(i, 1), arr(i, 1)
Next i
ReDim arr2(1 To col.Count, 1 To 3)
For i = 1 To col.Count
    arr2(i, 1) = "ÈÒÎÃÈ ÏÎ " & col(i)
    arr2(i, 2) = Application.WorksheetFunction.SumIfs(Columns(2), Columns(1), col(i))
Next i
Cells(lr + 1, 1).Resize(UBound(arr2), 3) = arr2
End Sub
Изменено: Mershik - 03.12.2021 15:40:35
Не бойтесь совершенства. Вам его не достичь.
Разбить текст ячейки для строки на наборы строк
 
Mikh1,  совет в правилах есть пункт:
Цитата
3.2. Использовать в сообщениях, подписях и логинах на форумах нецензурную лексику, текст с пЕреМеНнЫм регистром или бессмысленным набором символов, заменять буквы другими символами. Создавать аватары порнографического, политического или религиозного содержания.
измените имя лучше - моЖераторы сколько притопают)
Код
Sub mrshkei()
Dim arr, arr2, arr3, i As Long, n As Long
lr = Cells(Rows.Count, 2).End(xlUp).Row
arr = Range("B3:C" & lr)
For i = LBound(arr) To UBound(arr)
    arr2 = Split(arr(i, 2), ",")
    x = x + UBound(arr2) + 1
Next i
ReDim arr3(1 To x, 1 To 2): k = 1

For i = LBound(arr) To UBound(arr)
    arr2 = Split(arr(i, 2), ",")
    For n = LBound(arr2) To UBound(arr2)
        arr3(k, 1) = arr(i, 1)
        arr3(k, 2) = Trim(arr2(n))
        k = k + 1
    Next n
Next i
Range("E3").Resize(UBound(arr3), 2) = arr3
End Sub
Изменено: Mershik - 02.12.2021 09:38:18
Не бойтесь совершенства. Вам его не достичь.
Объединить столбцы в один столбец.
 
,
Код
Sub mrshkei()
Dim arr, arr2, i As Long, n As Long, k As Long, lr As Long, lcol As Long
lr = ActiveSheet.UsedRange.Rows.Count
lcol = ActiveSheet.UsedRange.Columns.Count
arr = Range(Cells(1, 1), Cells(lr, lcol))
ReDim arr2(1 To lr * lcol, 1 To 1): k = 1
For i = LBound(arr) To UBound(arr)
    For n = LBound(arr) To UBound(arr, 2) - LBound(arr) + 1
        If arr(i, n) <> Empty Then arr2(k, 1) = arr(i, n): k = k + 1
    Next n
Next i
Sheets.Add
With ActiveSheet
.Name = Replace(Now, ":", "-")
.Range("A1").Resize(UBound(arr2), 1) = arr2
End With
End Sub
Не бойтесь совершенства. Вам его не достичь.
Заполнить таблицу ТО из справочника цен, заменив + на нужную цену
 
Цитата
написал:
ПОМОГИТЕ, ПОЖАЛУЙСТА.
ЧТО? ГДЕ И КОГДА? - без файла не понять
Не бойтесь совершенства. Вам его не достичь.
Подсчёт суммы ячеек по цвету
 
, например вместо цвета -  отметку ставить кукую-то или согласно логике выделения цветом. и использовать обычные суммеслимн  или просто в формуле логику веделеняи прпоисать и сусммировать
Изменено: Mershik - 01.12.2021 15:14:52
Не бойтесь совершенства. Вам его не достичь.
Подсчёт суммы ячеек по цвету
 
Цитата
написал:
Помогите сократить формулу, возможно поможет.
уходите от подсчета по цвету и использования формулы
Не бойтесь совершенства. Вам его не достичь.
Добавить в конце таблицы строку из другой страницы
 
gasan aliev, зачем куча сообщений ?можно дополнять. не понял для чего добавлять строку поэтом просто добавляю в конец таблицы
Код
Sub mrshkei()
Dim sh As Worksheet, sh2 As Worksheet, lr As Long, lcol As Long, rng As Range
Set sh = Worksheets("таблица"): Set sh2 = Worksheets("Перенос (отсюда)")
Set rng = sh2.Range("K4:FC4")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
lcol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
    rng.Copy
    sh.Cells(lr, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
     Rows(lr - 2 & ":" & lr - 2).Copy
     Rows(lr & ":" & lr).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End Sub
еще вариант
Код
Sub mrshkei()
Application.ScreenUpdating = False
Dim sh As Worksheet, sh2 As Worksheet, lr As Long, lcol As Long, rng As Range, arr, i As Long, n As Long
Set sh = Worksheets("таблица"): Set sh2 = Worksheets("Перенос (отсюда)")
arr = sh2.Range("K3:FC4")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
lcol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
For n = 1 To lcol
    For i = LBound(arr) To UBound(arr, 2) - LBound(arr) + 1
        If arr(1, i) = sh.Cells(1, n) Then
        If arr(2, i) <> 0 Then
            sh.Cells(lr, n) = arr(2, i): Exit For
        End If
        End If
    Next i
Next n
     Rows(lr - 2 & ":" & lr - 2).Copy
     Rows(lr & ":" & lr).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Изменено: Mershik - 01.12.2021 15:01:17
Не бойтесь совершенства. Вам его не достичь.
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 271 След.
Наверх