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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 61 След.
Редизайнер многоуровневой таблицы, Адаптация примера Николая Павлова
 
Добрый день
Еще вариант
В перечне с функциями непонятные значки, что это за Excel-сущность
 
Формулы -> Диспетчер имен
Как выделить определенные столбцы в таблицы (Show Details) из сводной таблицы?, Как выделить определенные столбцы в таблицы (Show Details) из сводной таблицы?
 
Добрый день. В модуль листа "Сводная":
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim pc As PivotCell
    Dim sc As Integer, r As Long
    Dim sh As Worksheet
    
    On Error Resume Next
        Set pc = Target.PivotCell
        If Err Then Exit Sub
        sc = ThisWorkbook.Sheets.Count
        Target.ShowDetail = True
        If Err Then Exit Sub ' если нельзя выполнить ShowDetail
    On Error GoTo 0
    
    If ThisWorkbook.Sheets.Count > sc Then 'если добавился лист
        Set sh = ActiveSheet
        r = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
        sh.Range(sh.Cells(1, 1), sh.Cells(r, 6)).Copy Destination:=sh.Cells(r + 6, 1)
        sh.Cells(r + 6, 7).Formula = "=формула_1"
        sh.Cells(r + 7, 7).Formula = "=формула_2"
        sh.Cells(r + 5, 8).Formula = "=формула_3"
        sh.Cells(r + 7, 8).Formula = "=формула_4"
    End If
    Cancel = True
End Sub
Блокировка только что редактируемых ячеек после сохранения
 
Добрый день
Наверное как-то так
Извлечь числа из текста одинакового формата
 
Добрый день. Ну в итоге я себе это вижу примерно так
Заменить символы в ячейке из списка
 
добрый день. UDF
Код
Public Function CodeReplace(st As String, rn As Range)
    Dim j As Integer, arr()
    arr = rn
    If InStr(1, st, "xxxx=") > 0 Then
        st = Mid(st, InStr(1, st, "xxxx=") + 5, Len(st))
    End If
    For j = 1 To UBound(arr)
        st = Replace(st, arr(j, 2), arr(j, 1))
    Next j
    CodeReplace = st
End Function
Очистить содержимое ячеек с повторяющимися значениями, В таблице на 5 000 строк необходимо очистить содержимое ячеек с повторяющимися значениями. Оставить уникальное значение. Пример Было-Стало во вложении
 
через доп столбец.
PS а дальше отфильтровать и удалить руками
Изменено: webley - 2 Авг 2018 12:25:24
Извлечь числа из текста одинакового формата
 
Код
Public Function TimeSum(rn As Range, rnmark As Range, Optional oper As String)
    Dim st As String, j As Integer, k As Integer
    If rn.Cells.Count <> rnmark.Cells.Count Then Exit Function
    TimeSum = 0
    For j = 1 To rn.Cells.Count
        If rnmark.Cells(j) <> "" Then
            st = rn.Cells(j)
            k = k + 1
            If st <> "" Then
                st = Replace(st, "сут.", "+")
                st = Replace(st, "час.", "/24+")
                st = Replace(st, "мин.", "/24/60")
                st = Replace(st, " ", "")
                If Right(st, 1) = "+" Then st = Left(st, Len(st) - 1)
                TimeSum = TimeSum + Application.Evaluate(st)
            End If
        End If
    Next j
    If oper = "avg" Then TimeSum = TimeSum / k
    TimeSum = Int(TimeSum) & " сут. " & Format(TimeSum, "h час. m мин.")
End Function
Извлечь числа из текста одинакового формата
 
Ну тогда так:
Код
Public Function TimeSum(rn As Range, Optional oper As String)
    Dim c As Range, st As String
    TimeSum = 0
    For Each c In rn
        st = c.Value
        If st <> "" Then
            st = Replace(st, "сут.", "+")
            st = Replace(st, "час.", "/24+")
            st = Replace(st, "мин.", "/24/60")
            st = Replace(st, " ", "")
            If Right(st, 1) = "+" Then st = Left(st, Len(st) - 1)
            TimeSum = TimeSum + Application.Evaluate(st)
        End If
    Next c
    If oper = "avg" Then TimeSum = TimeSum / rn.Cells.Count
    TimeSum = Int(TimeSum) & " сут. " & Format(TimeSum, "h час. m мин.")
End Function
Извлечь числа из текста одинакового формата
 
Вариант udf, которая сразу сумму считает:
Код
Public Function TimeSum(rn As Range)
    Dim c As Range, st As String
    For Each c In rn
        st = c.Value
        st = Replace(st, "сут.", "+")
        st = Replace(st, "час.", "/24+")
        st = Replace(st, "мин.", "/24/60")
        st = Replace(st, " ", "")
        TimeSum = TimeSum + Application.Evaluate(st)
    Next c
    TimeSum = Int(TimeSum) & " сут. " & Format(TimeSum, "h час. m мин.")
End Function
Копирование строки на другую страницу, если в первой ячейке определенный текст
 
Цитата
fefil написал:
Как то можно этого избежать
можно перед строкой    
Код
For r = 1 To sh.Cells(sh.Rows.Count, 2).End(xlUp).Row
добавить
Код
    ThisWorkbook.Sheets("ам").Cells.Clear
    ThisWorkbook.Sheets("ат").Cells.Clear
тогда при каждом запуске макроса данные на этих листах будут очищаться
Копирование строки на другую страницу, если в первой ячейке определенный текст
 
Добрый день
Цитата
fefil написал:
Помогите подобрать формулу, если возможно
насчет формулы не знаю, а вот макросом можно примерно так:
Код
Sub test()
    Dim r As Long
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Общий")
    For r = 1 To sh.Cells(sh.Rows.Count, 2).End(xlUp).Row
        If sh.Cells(r, 2) Like "*ам*" Or sh.Cells(r, 2) Like "*ат*" Then
            With ThisWorkbook.Sheets(IIf(sh.Cells(r, 2) Like "*ам*", "ам", "ат"))
                sh.Rows(r).Copy Destination:=.Rows(.Cells(.Rows.Count, 2).End(xlUp).Row + 1)
            End With
        End If
    Next r
    sh.Range("A1").Select
    MsgBox "Done"
End Sub
Как выделить жирным шрифтом конкретное слово в тексте, на основании маски примера?
 
Добрый день. Как уже говорилось выше - макросом можно. Думаю это подходит под определение "или что-то еще" :)
Код
Sub test()
    Dim r As Long
    For r = 2 To Cells(Rows.Count, 3).End(xlUp).Row
        If Cells(r, 4) Like "*" & Cells(r, 3) & "*" Then
            Cells(r, 4).Characters(InStr(1, Cells(r, 4), Cells(r, 3)), Len(Cells(r, 3))).Font.Bold = True
        End If
    Next r
End Sub
Нужен код VBA для удаления определенных листов книги
 
Добрый день.
Код
Sub SheetsDel()
    Dim j As Integer
    Application.DisplayAlerts = False
        For j = ThisWorkbook.Sheets.Count - 2 To 2 Step -1
            ThisWorkbook.Sheets(j).Delete
        Next j
    Application.DisplayAlerts = True
End Sub
Хотя на мой взгляд проще выделить ненужные листы и просто удалить:)
Выделение иерархии в сводной таблице активной ячейки
 
Добрый день. Поменяйте строку
Код
st = st & "'" & pc.RowItems(j) & "' "
на строку
Код
st = st & "'" & pc.RowItems(j).Parent.Name & "'['" & pc.RowItems(j) & "'] "
Выделение иерархии в сводной таблице активной ячейки
 
Добрый день. В модуль листа:
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim pc As PivotCell, pt As PivotTable
    Dim st As String, j As Integer
    
    On Error Resume Next
        Set pc = ActiveCell.PivotCell
        If Err.Number <> 0 Then Exit Sub
        If pc.PivotCellType <> xlPivotCellValue Then Exit Sub
        If pc.RowItems.Count = 0 Then Exit Sub
    On Error GoTo 0
    
    Set pt = ActiveCell.PivotTable
    
    For j = 1 To pc.RowItems.Count
        st = st & "'" & pc.RowItems(j) & "' "
    Next j
    st = Left(st, Len(st) - 1)
    pt.PivotSelect st, xlDataAndLabel, True
End Sub

срабатывает при выделении любого числового значения. Единственное, не корректно с промежуточными итогами работает
VBA - GETPIVOTDATA при неизвестном заранее количестве аргументов
 
Добрый день
Код
    t = "'Сумма по полю Количество услуг' Клиент A Филиал MOW"
    y = pt.GetData(t)
    MsgBox y
Удаление одинаковых строк, если их меньше определенного количества, Удаление одинаковых строк, если их меньше определенного количества
 
ну вот
Удаление одинаковых строк, если их меньше определенного количества, Удаление одинаковых строк, если их меньше определенного количества
 
сделать дополнительный столбец =СЧЁТЕСЛИ(A:A;A2) (с учетом, что наименования находятся в столбце А) и отфильтровать по нему
Макрос на объедение 2 ячеек по условию
 
формулы вы не проверяли, если только макрос - но там Юрий оговорил ограничение на длину л/с
Макрос на объедение 2 ячеек по условию
 
Цитата
Zigain написал:
У вас фиксированное значение нулей
это не фиксированное количество нулей, а фиксированное количество знаков - если длина л/с меньше, то тогда будет добавлено необходимое кол-во нулей слева.
а вообще - попробуйте предложенные варианты с лицевыми счетами разной длины и вы убедитесь, что Вас прекрасно поняли и сделали так, как нужно :)
Макрос на объедение 2 ячеек по условию
 
формулой:
Код
=ИНДЕКС(Города!A:A;ПОИСКПОЗ(C2;Города!B:B;0))&ПРАВСИМВ("000000000"&A2;9)
Получение суммы (произведений) из другой ячейки, Ищу формулу для получения суммы (произведений) из другой ячейки
 
udf:
Код
Public Function Calc(st As String)
    Calc = Application.Evaluate(st)
End Function
Вставка точки после цифры.
 
Добрый день. Может вот так?
Код
=ЕСЛИОШИБКА(ЕСЛИ(ПРОМЕЖУТОЧНЫЕ.ИТОГИ(3;B2);ПОДСТАВИТЬ(A1;".";"")+1;ПОДСТАВИТЬ(A1;".";""));1)&"."
Макрос для запуска пользовательской функции
 
Надо без кавычек, но с указанием аргумента:
Код
Sub Ф()
    MsgBox Пример(1)
End Sub
 
Function Пример(Число As String)
    Пример = Число * 2
End Function
Извлечения текста из ячейки
 
А если воспользоваться вот этим способом? https://www.planetaexcel.ru/techniques/7/4844/
Очень хорошо подходит к Вашему случаю
Извлечения текста из ячейки
 
Добрый день
А вот так не подойдет?
Код
=ПСТР(A1;НАЙТИ("77_";A1);8)
Изменено: webley - 20 Июн 2018 11:25:32
Как удалить лишних пробелов в тексте
 
Цитата
Stics написал:
Но может кто и макросом поможет
Выделить нужный диапазон и запустить макрос:
Код
Sub test()
    Dim c As Range
    For Each c In Selection
        c = Replace(c, Chr(160), Chr(32))
        c = WorksheetFunction.Trim(c)
    Next c
    MsgBox "Done"
End Sub
Изменено: webley - 19 Июн 2018 15:55:52
Совмещение осей в ComboChart, Необходимо совместить оси
 
Добрый день. Можно поставить границы осей вручную:
ПОИСКПОЗ: сообщение при проверке наличия элемента в массиве
 
Код
MsgBox IIf(IsError(Application.Match("test", Columns(1), 0)), "Не найдено", "найдено")
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 61 След.