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

Страницы: 1 2 След.
Как макросом отчистить ячейки по условию
 
Спасибо, забыл про свой вопрос, поэтому не своевременно по благодарил. А, можно подправить, чтобы выполнял тоже самое, но где есть набор определенных символов например "!%?"
Результат числа зависит от сколько знаков после запятой в погрешности
 
Ну а в посте №4, откуда взяли формулу, там нет ссылки "D14", "E14" из моего первого примера. Во вложенном примере из поста №12 я ошибся указав на формулу из ячейки "P16", смотрите результат  из ячейки "P15"
Цитата
tutochkin написал:
А можно сделать пример с тремя ячейками.
Надо в одной ячейки
Результат числа зависит от сколько знаков после запятой в погрешности
 
Во первых, Вы вытащили мою формулу и вставили к себе в файл, не обратив внимания на, то что она еще ссылается на ячейки "D14", "E14" (границы), эта уже отклонение от моей формулы. Вообщем картинку прикрепил, с "5,2" и "5,6" всё считает, не знаю почему у Вас не считает. Если будете работать вот файл работайте в нём. А Ваше второе предложение с формулой "Если хочется без VBA, то вот такая строка:", это длинная
Результат числа зависит от сколько знаков после запятой в погрешности
 
Подправил чуть-чуть, всё сходиться
Результат числа зависит от сколько знаков после запятой в погрешности
 
Цитата
Что то у меня оба предложенных варианта не заработали как требуется.
Вот пример
Изменено: Lerik2020 - 28.10.2021 13:46:00
Результат числа зависит от сколько знаков после запятой в погрешности
 
Я, так понимаю здесь надо еще до думать, это перевести формулы с английского на русский заменить "4,6" и "1,3" на формулы чтобы получить формулу следующего вида
Скрытый текст
Если так, то спасибо
Результат числа зависит от сколько знаков после запятой в погрешности
 
Здравствуйте, нужна помощь в написании формулы. На примере №1 объясню, если результат равняется "5", а погрешность "1,3", то запись должна быть "5,0±1,3",то есть если у погрешности после запятой есть знак, то число нужно выводить то же после запятой знак. Примере №2 , если результат равняется "5", а погрешность "1", то запись должна быть "5±1, Примере №3 , если результат равняется "4,6", а погрешность "1", то запись должна быть "4,6±1,0. Погрешность может быть разные цифры, это я так в пример привел, не обязательно "1,3" или "1", также и в числе. Я смог реализовать  получить нужный результат, но слишком много формул пришлось создать. Может у кого то по короче получиться.
Как макросом отчистить ячейки по условию
 
Здравствуйте подскажите пожалуйста. Как макросом отчистить ячейки по условию. Например в столбце "B:B" имеются такие записи ("№ договора", "от какого числа", "протокол № ", "Дата и время", а в столбце "C:C", идет заполнение. Можно ли ориентируясь на столбца "B:B" очистить заполнение в столбце "C:C". Можно фиксированно конечно сделать, какие ячейки отчистить, а если скажем строки по едут на одну сместятся, верх или вниз, то геморройно будет опять перебивать в какие ячейки отчистить от информации .

Или может просто выделить определенный столбец в котором будет символы например "$%@^", то ячейки из столбца "C:C" очистить. Например если в ячейка "B11" есть эти символы "$%@^", то ячейку "C11" отчистить от информации, наверно так проще будет.
Как из одной ячейки исключить слова находящиеся в других ячейках
 
Msi2102, да Вы правы, забыл написать, дошло что надо писать так "=СцепитьМного(B13:K13;"; "&СИМВОЛ(10);1;O13:X13)"
Как из одной ячейки исключить слова находящиеся в других ячейках
 
НУ да, ооочень круто, спасибо. А еще один вопрос, а если у меня сцепляет вот такого типа формулы "=ЕСЛИ(C6="";"";C6&СИМВОЛ(10))"", то тогда разделитель ставиться в начале, а не в конце. Ну это не критично, но все же может быть можно, сделать, чтобы он прописывался в конце. Я сделал так эту формулу, чтобы после сцепления Показывался весь текст ни одной строкой, а типа через ALT+ENTER
Как из одной ячейки исключить слова находящиеся в других ячейках
 
А со "сцепить много", как то можно подружить Вашу функцию?
Как из одной ячейки исключить слова находящиеся в других ячейках
 
Здравствуйте, подскажите пожалуйста как из одной ячейки исключить слова находящиеся в других ячейках. У меня в ячейка "B13:K13", находятся текст который сцепляется функцией "сцепитьмного", взял отсюда, теперь нужно исключить слова из этой функции, которые находятся в ячейках "O13:X13". Можно конечно воспользоваться функцией "подставить", но это нужно прописывать для каждой ячейки. Есть какой-нибудь способ по короче?
Поиск в выпадающем списке с выводом двух значений
 
Странное понятие у Вас о детских вопросах, вы не по адресу. Я разобрался. Вот код может кому надо будет.
Код
Option Explicit
Option Compare Text

Private Sub Comm1_Click()
    Dim r As Integer, C As Integer
    If ListBox1.ListIndex = -1 Then Exit Sub
    If Not ActiveSheet Is iSheetLists Then
        If ActiveSheet.ProtectContents = True And ActiveCell.Locked = True Then
            MsgBox "Лист защищен! Что бы вставить значение, снимите защиту листа."
        Else
            ActiveCell.Value = ListBox1.Text
            Select Case iShiftOption
            Case 0: r = 0: C = 0
            Case 1: r = -1: C = 0
            Case 2: r = 0: C = 1
            Case 4: r = 0: C = -1
            Case Else: r = 1: C = 0
            End Select
            On Error Resume Next
            'AppActivate "Microsoft Excel"
            ActiveCell.Offset(r, C).Activate
            ListBox1.SetFocus
            On Error GoTo 0
        End If
    End If
End Sub

Private Sub HelpButton_Click()
    Me.Hide
    With HelpForm
        .Top = Me.Top
        .Left = Me.Left
        .Show
    End With
    Me.Show
End Sub

Private Sub ListBox1_Click()
    Call MyControlsState(Not ListBox1.ListIndex = -1)
    NewItButton.Enabled = Not TextBoxItems.Text = ""
End Sub

Private Sub ListBoxItems_Click()
Dim arr, i As Long, MainValue As String
 
    If Me.ListBoxItems.ListCount = 0 Then Exit Sub
    arr = Worksheets("Список").Range("A1").CurrentRegion.Value
    For i = 0 To Me.ListBoxItems.ListCount - 1
        If Me.ListBoxItems.Selected(i) Then
            MainValue = Me.ListBoxItems.List(i)
            Exit For
        End If
    Next
    If MainValue = "" Then Exit Sub
    Me.ListBox1.Clear
    For i = 1 To UBound(arr)
        If arr(i, 1) = MainValue Then Me.ListBox1.AddItem arr(i, 2)
    Next i
End Sub

'----------------------------------------------------------
'----------------------------------------------------------

Private Sub UserForm_Initialize()
    Me.Tag = 1
    Me.Caption = AppName
    If iMainFormPosOption = 1 Then Call mySetFormKoord(Me)    ' устанавливаем координаты формы
    Call AssigningValuesToVariables    ' присваиваем значения переменным
    Call MyFillDataControlLists(ComboBoxLists)    ' заполняем данными комбобокс с названиями списков и устанавливаем в нем текущий єлемент.
    If dLists.Count = 0 Then
        MsgBox "Нет списков для выбора!" & vbCrLf & "Для продолжения работы добавьте хотя бы один список." _
               , vbExclamation + vbOKOnly, AppName
        SettingsForm.Show
        Call MyFillDataControlLists(ComboBoxLists)
    End If
End Sub

Private Sub AssigningValuesToVariables()
    Call myGetCustomProperties("NumListColumn", 1, iNumListColumn)
    Call myGetCustomProperties("SortingOption", 1, iSortingOption)
    Call myGetCustomProperties("ShiftOption", 3, iShiftOption)
    Call myGetCustomProperties("DblClickRunOption", 1, iDblClickRunOption)
    Call myGetCustomProperties("FindOption", 1, iFindOption)
    Call myGetCustomProperties("MainFormPosOption", 1, iMainFormPosOption)
End Sub

Private Sub myGetCustomProperties(prName As String, prValueDefault As Long, prValue As Long)
    On Error Resume Next
    With ThisWorkbook.CustomDocumentProperties
        If Not MyCustomPropertiesExists(prName) Then _
           Call MyCreateCustomProperties(prName, prValueDefault)
        prValue = CLng(.Item(prName))
        If Not Err.Number = 0 Then prValue = prValueDefault
    End With
    On Error GoTo 0
End Sub

Private Sub ComboBoxLists_Change()
    Dim s
    TextBoxItems.Text = ""
    ListBoxItems.Clear
    If ComboBoxLists.Text = "" Then Exit Sub
    s = ComboBoxLists.Text
    If IsNumeric(s) Then s = Val(s)
    iNumListColumn = dLists.Item(s)
    Call MyFillDataControlItems(ListBoxItems)
End Sub

Private Sub ListBoxItems_Change()
    Call MyControlsState(Not ListBoxItems.ListIndex = -1)
    NewItButton.Enabled = Not TextBoxItems.Text = ""
End Sub
Private Sub MyControlsState(ContrlState As Boolean)
    OKButton.Enabled = ContrlState
    DelItButton.Enabled = ContrlState
    NewItButton.Enabled = ContrlState
End Sub
Private Sub MyControlsState22(ContrlState As Boolean)
    Comm1.Enabled = ContrlState
    DelItButton.Enabled = ContrlState22
    NewItButton.Enabled = ContrlState22
End Sub
Private Sub TextBoxItems_Change()
    Dim s As String, it
    NewItButton.Enabled = Not TextBoxItems.Text = ""
    If ComboBoxLists.Text = "" Or _
       dLists.Count = 0 Then NewItButton.Enabled = False: Exit Sub
    If dItems.Count = 0 Then Exit Sub
    ListBoxItems.Clear
    If TextBoxItems.Text = "" Then
        ListBoxItems.List = dItems.keys
    Else
        s = "*" & TextBoxItems.Text & "*"
        If iFindOption = 2 Then s = Mid(s, 2)
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For Each it In dItems.keys
                If it Like s Then .Item(it) = ""
            Next it
            If .Count = 0 Then Exit Sub
            ListBoxItems.List = .keys
        End With
    End If
    ListBoxItems.ListIndex = 0
End Sub

Private Sub CancelButton_Click()
    Unload Me
End Sub

Private Sub ComboBoxLists_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = 0
End Sub

Private Sub DelItButton_Click()
    Dim r As Range
    If MsgBox("Вы действительно хотите удалить" & vbCrLf & "элемент: " & _
              ListBoxItems.Text & vbCrLf & "из списка: " & ComboBoxLists.Text & " ?", vbOKCancel + vbExclamation, _
              "Удаление элемента списка") = vbOK Then
        With iSheetLists.Columns(iNumListColumn)
            On Error Resume Next
            Set r = .Find(What:=ListBoxItems.Text, LookIn:=xlValues, LookAt:=xlWhole)
            If Not r Is Nothing Then r.Delete Shift:=xlUp
        End With
        dItems.RemoveAll
        TextBoxItems.Text = ""
        Call MyFillDataControlItems(ListBoxItems)
    End If
End Sub

Private Sub ListBoxItems_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Call OKButton_Click
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Call Comm1_Click
End Sub
Private Sub NewItButton_Click()
    Dim s
    s = TextBoxItems.Text
    If IsNumeric(s) Then s = Val(s)
    If Len(Trim(s)) = 0 Then Exit Sub
    If dItems.Exists(s) Then
        MsgBox "Элемент: " & s & vbCrLf & "уже есть в этом списке !"
        Exit Sub
    End If
    With iSheetLists
        On Error Resume Next
        .Cells(.Rows.Count, iNumListColumn).End(xlUp).Offset(1, 0).Value = s
    End With
    dItems.RemoveAll
    TextBoxItems.Text = ""
    Call MyFillDataControlItems(ListBoxItems, s)
End Sub

Private Sub OKButton_Click()
    Dim r As Integer, C As Integer
    If ListBoxItems.ListIndex = -1 Then Exit Sub
    If Not ActiveSheet Is iSheetLists Then
        If ActiveSheet.ProtectContents = True And ActiveCell.Locked = True Then
            MsgBox "Лист защищен! Что бы вставить значение, снимите защиту листа."
        Else
            ActiveCell.Value = ListBoxItems.Text
            Select Case iShiftOption
            Case 0: r = 0: C = 0
            Case 1: r = -1: C = 0
            Case 2: r = 0: C = 1
            Case 4: r = 0: C = -1
            Case Else: r = 1: C = 0
            End Select
            On Error Resume Next
            'AppActivate "Microsoft Excel"
            ActiveCell.Offset(r, C).Activate
            ListBoxItems.SetFocus
            On Error GoTo 0
        End If
    End If
End Sub

Private Sub SettingsButton_Click()
    Call MyControlsState(False)
    Me.Hide
    SettingsForm.Show
    ListBoxItems.Clear
    Call MyFillDataControlLists(ComboBoxLists)
    If Not dLists.Count = 0 Then
        Call MyFillDataControlItems(ListBoxItems)
    End If
    TextBoxItems.Text = ""
    Me.Show 0
End Sub

Private Sub UserForm_Terminate()
    Call mySetCustomProperties("NumListColumn", iNumListColumn)
    Call mySetCustomProperties("SortingOption", iSortingOption)
    Call mySetCustomProperties("ShiftOption", iShiftOption)
    Call mySetCustomProperties("DblClickRunOption", iDblClickRunOption)
    Call mySetCustomProperties("FindOption", iFindOption)
    Call mySetCustomProperties("MainFormPosOption", iMainFormPosOption)

    Set dLists = Nothing
    Set dItems = Nothing
 
End Sub

Private Sub mySetCustomProperties(prName As String, prValue As Long)
    On Error Resume Next
    With ThisWorkbook.CustomDocumentProperties
        If MyCustomPropertiesExists(prName) Then
            .Item(prName).Value = prValue
        Else
            Call MyCreateCustomProperties(prName, prValue)
        End If
    End With
    On Error GoTo 0
End Sub
Изменено: Lerik2020 - 22.07.2020 00:03:55
Поиск в выпадающем списке с выводом двух значений
 
Да то что нужно, спасибо огромнейшее!!! Подскажите, а как сделать чтобы он еще в ячейку вставлял???
Поиск в выпадающем списке с выводом двух значений
 
Извините, вот файл
Изменено: Lerik2020 - 21.07.2020 17:41:39
Поиск в выпадающем списке с выводом двух значений
 
Здравствуйте помогите сделать поиск в выпадающем списке с выводом двух значений? В прилагаемом примере поиск осуществляется по одному списку взяты с определенного столбца "A:A" и безв повторяющегося значения. А нужно чтобы он выводил в одном окне весь список из столбца "A:A", а во втором окне весь список из столбца "B:B". Например надо найти "Метан", ввожу его и нужно чтобы в первом оне вышли все варианты "Метан" из столбца "A", а во втором окне список из столбца "B" варианты которые расположены на против их, то есть например "A10" соответствует "B10"
Отправка файлов по электронной почте находящихся в одном файле
 
Макрос запускает outlook с прикрепленными файлами, я нажимаю отправить, outlook закрывается, но ни чего не приходит. Приходится вручную запускать outlook, и только после этого письмо приходит
Отправка файлов по электронной почте находящихся в одном файле
 
Вот сделал как Вы и сказали, outlook выполняет отправку но, ни чего не приходит. У меня в папке два файла, outlook дважды запускается, получается он пытается отправить два письма, и если в папке будет 10 файлов, столько же раз отправит. А одним разом как то можно сделать?
Код
Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'открываем книгу
        Workbooks.Open sFolder & sFiles
        'действия с файлом
Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
      
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")   'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon      
    On Error GoTo cleanup  'если не запустился - выходим 
    Set OutMail = OutApp.CreateItem(0)   'создаем новое сообщение
    On Error Resume Next
    'заполняем поля сообщения
    With OutMail
        .To = Range("A1").Value
        .Subject = Range("A2").Value
        .Body = Range("A3").Value
        .Attachments.Add Range("A4").Value
        'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой 
        .Send
    End With
  
    On Error GoTo 0
    Set OutMail = Nothing
  
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True

        'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
End Sub
Изменено: Lerik2020 - 05.03.2020 23:31:15
Отправка файлов по электронной почте находящихся в одном файле
 
Не совсем понял как, это сделать?
Отправка файлов по электронной почте находящихся в одном файле
 
Подскажите пожалуйста, а можно ли в этом макросе прописать, чтобы он отправлял ни один файл а все файлы разом находящиеся в одной папке. Макрос взял отсюда
Код
Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
     
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")   'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon      
    On Error GoTo cleanup  'если не запустился - выходим 
    Set OutMail = OutApp.CreateItem(0)   'создаем новое сообщение
    On Error Resume Next
    'заполняем поля сообщения
    With OutMail
        .To = Range("A1").Value
        .Subject = Range("A2").Value
        .Body = Range("A3").Value
        .Attachments.Add Range("A4").Value
        'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой 
        .Send
    End With
 
    On Error GoTo 0
    Set OutMail = Nothing
 
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub
Макрос скопировать выделенные строки из одной таблицы в другу таблицу
 
Всё разобрался
это
Код
Set rn = Cells(ActiveCell.Row, 1).Copy
заменил на
Код
Set rn = Selection.EntireRow

Макрос скопировать выделенные строки из одной таблицы в другу таблицу
 
Здравствуйте нужна помощь. Мне нужно скопировать выделенные строки из одной таблицы в другу таблицу, на конкретный лист в последнюю не заполненную ячейку. Вот нашел  макрос
Код
Sub transponir22() ' переносим файлы в общий отчет
Dim x1 As Long, rn As Range
Set rn = Cells(ActiveCell.Row, 1).Copy
Workbooks.Open Filename:="D:\Данные\Хранение.xlsm" ' открываем файл отчета
x1 = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range(Cells(x1, 1), Cells(x1 + rn.Rows.Count - 1, 1)).NumberFormat = "@"
Range(Cells(x1, 1), Cells(x1 + rn.Rows.Count - 1, rn.Columns.Count)).Value = rn.Value
ActiveWorkbook.Close 1 'закрываем с сохранением
End Sub

Но он копирует конкретную строку из одной таблицы, на лист в котором было последнее сохранение
Изменено: Lerik2020 - 26.02.2020 01:21:14
Формула поиска по выбранному листу и двум значениям
 
У меня получилось так. В "Проверка данных",  "выпадающий список", я ввел следующую формулу
Код
=ЕСЛИ(A3="Лист1";Лист1!B1:B3;ЕСЛИ(A3="Лист3";Лист3!B1:B3;ЕСЛИ(A3="Лист4";Лист4!B1:B3)))
У меня будет 50 листов, т.е для каждого делать так, а по короче можно как-то?
Изменено: Lerik2020 - 02.02.2020 00:03:36
Формула поиска по выбранному листу и двум значениям
 
Ну там же указано когда все находится на одном листе, а у меня на разных, и там нет поиска с указанием листов
Формула поиска по выбранному листу и двум значениям
 
Нет, в моём случае, это не подойдет, к сожалению.
Формула поиска по выбранному листу и двум значениям
 
Спасибо вам большое! Забыл указать в описании, а как сделать, так чтобы в зависимости от того какой мы лист выбираем, то и менялись бы выпадающие списки по критериям. Столбцы для критериев на всех листах одинаковые.
Изменено: Lerik2020 - 31.01.2020 06:31:20
Формула поиска по выбранному листу и двум значениям
 
Здравствуйте подскажите пожалуйста в таком вопросе. Вот есть такай формула массива =ИНДЕКС(Лист1!C:C;ПОИСКПОЗ(B3&C3;Лист1!A:A&Лист1!B:B;0)), она ищет по двум критериям,а есть возможность указать формуле, в выпадающем списке на каком листе искать. Листов около 70 хотелось бы упростить поиск
Макрос найти данные в определенной книги из активной книги, и перенести в определенную книгу
 
МатросНаЗебре Подскажите, а можно сделать, так чтобы макрос делала тоже самое, но копировал не диапазон, а конкретные ячейки, например "A8", "D8", "G8", "K8", "M8". Забыл про такой момент , что данные не только должны заменятся но еще и добавляться.
Работа макроса через интернет
 
Проблема такая хотим вечером по работать через интернет. Тема такая мы установили программу "Hamachi", настроил доступ через интернет к папке на компьютер, который находится в офисе, разрешение на создание и переименование есть, с этим проблем нет, проблема в том что когда запускаем Excel файл, запускаем работу макроса то он ищет файл на моем компьютере чтобы выполнить в него запись, а как прописать путь, чтобы он вносил изменения через мой компьютер на компьютер который подключен через интернетhttp://hamachi-pc.ru/
Код
onst DB_FULLNAME = "C:\tmp\База данных.xlsm"
 
Sub УшлаНаБазу()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    Dim sName As String
    sName = fso.getfilename(DB_FULLNAME)
     
    Dim bClose As Boolean
    Dim wb As Workbook
    On Error Resume Next
        Set wb = Workbooks(sName)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = Workbooks.Open(DB_FULLNAME, False, False)
        bClose = True
    End If
     
    Dim shI As Worksheet: Set shI = Workbooks("Отправка.xlsm").Worksheets("Инф")
    Dim shZ As Worksheet: Set shZ = wb.Worksheets("Заявки")
      
    Dim a As Variant
    a = shI.Range("A8:J8")
      
    Dim y As Long
    If a(1, 1) <> "" Then
        On Error Resume Next
            y = WorksheetFunction.Match(a(1, 1), shZ.Columns(1), 0)
        On Error GoTo 0
    End If
      
    If y > 0 Then
        shZ.Cells(y, 1).Resize(1, UBound(a, 2)).Value = a
    End If
     
    If bClose Then
        Application.DisplayAlerts = False
        wb.Close True
        Application.DisplayAlerts = True
    End If
End Sub
Изменено: Lerik2020 - 16.01.2020 19:17:25
Макрос найти данные в определенной книги из активной книги, и перенести в определенную книгу
 
Спасибо большое дай Бог Вам здоровья!!!
Страницы: 1 2 След.
Наверх