МатросНаЗебре (Все сообщения пользователя)

Макрос что бы скрыть столбцов

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

26.04.2024 15:28:59

Код

Sub myRefresh()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        RefreshSheet sh
    Next
End Sub

Private Sub RefreshSheet(sh)
    If sh.Range("B2") = 0 Then
        sh.Columns("F:P").EntireColumn.Hidden = True
            Else
                sh.Columns("F:P").EntireColumn.Hidden = False
    If sh.Range("B3") = 0 Then
        sh.Columns("G:P").EntireColumn.Hidden = True
            Else
                sh.Columns("G:P").EntireColumn.Hidden = False
            End If
        End If
End Sub

Перейти

Зачем сражаться за секунды выигрыша по скорости работы макроса?

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 26.04.2024 14:06:07 Демонстрируется возможность оптимизации кода. Выражаясь простым языком, "применяя такой метод, мы на каждом шаге экономим 1 секунду, если таких шагов будет 1000, то сэкономим 20 минут."
	Перейти

Подбор в столбец из другого столбца + заполнение соседнего, Реестр документов

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

26.04.2024 14:01:39

Цитата
написал: И в тот момент, когда она доходит до ввода в поле контрагент и набирает на клавиатуре первые буквы,

Если в столбец, в который вводите данные, внести список контрагентов, и в этом столбце не будет пустых строк, то будет срабатывать штатное Excel автозаполнение.

Цитата
написал: при выборе нужного контрагента захватывался соответствующий бы адрес из того же листа2 "данные" и заполнял ячейку Адреса на листе №1.

Решается через ВПР().

Перейти

Как в массиве вытянуть данные столбца, Найти значения столбца по данным таблицы и шапки таблицы

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

26.04.2024 13:44:03

Цитата
написал: вот зачем плохому учить? )

Майкл не возражал против использования волатильных функций, пусть по незнанию, но не возражал же )

Перейти

Как в массиве вытянуть данные столбца, Найти значения столбца по данным таблицы и шапки таблицы

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

26.04.2024 13:36:20

Код
=ЕСЛИОШИБКА(ИНДЕКС($E$1:$E$14;100-НАИБОЛЬШИЙ((СМЕЩ($E$10:$E$14;0;ПОИСКПОЗ($E$17;$F$9:$L$9;0))=$E$16)*(100-СТРОКА($E$10:$E$14));СТРОКА(1:1)));"")

Вводить как формулу массива. Ctrl+Shift+Enter.
В ячейку D2 и протянуть вниз.

Перейти

Найти последнее значение в столбце для функции если(IF)

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 26.04.2024 13:29:37 Соррян. Не мне кому-то советовать сменить отображаемое имя с моим-то ником
	Перейти

Найти последнее значение в столбце для функции если(IF)

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

26.04.2024 12:40:29

Вариант с формулой массива. Вводить Ctrl+Shift+Enter. В ячейку C13

Код
=ОКРУГЛ((((B13ЕСЛИ(E10="";ИНДЕКС($E$1:E13;МАКС(($E$1:E13>0)СТРОКА($E$1:E13)));E10))*0,01));2)

Перейти

Найти последнее значение в столбце для функции если(IF)

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

26.04.2024 12:35:38

Вариант с дополнительным столбцом. Вставьте в F2 и протяните вниз

Код
=ЕСЛИ(E2=0;F1;E2)

Перейти

Цикл на поиск ближайшей большей назначенной даты., С помощью Find ищу дату в диапазоне. Если есть, то определяет номер строки. Если нет! Помогите создать цикл на myPhrase = myPhrase + 1

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

26.04.2024 12:31:02

Код

    Dim myPhrase As Variant, myCell As Range
    Workbooks(1).Activate
    myPhrase = Range("F4").Value 'Это дата в ячейке
    Workbooks(2).Activate
    Do
        Set myCell = Range("G2:G1200").Find(myPhrase)
        If Not myCell Is Nothing Then
            MsgBox myCell.Row 'выводит номер строки, если нашел
            Exit Do
        Else
            MsgBox "даты нет!"
            myPhrase = myPhrase + 1
            If myPhrase > DateSerial(2030, 1, 1) Then
                MsgBox "Устал.", vbCritical
                Exit Do
            End If
            'Нужно настроить цикл на поиск ближайшей большей даты myPhrase, чтобы возвращал на If
        End If
    Loop

Перейти

Удаление строк в таблице от "Условие" до "Условие"

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 26.04.2024 11:50:52 Это Excel чудит при копировании листа.
	Перейти

Цикличный перебор значений в таблице по строкам, по пяти критериям, и в конце посчитать сумму.

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 26.04.2024 11:32:21 Перемудрили. Про формулы массива не было ни слова.
	Перейти

Удаление строк в таблице от "Условие" до "Условие"

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

26.04.2024 11:28:00

Код

Option Explicit

Sub SplitActiveWorkbook()
    CloseEmptyWb
    SplitWorkbook ActiveWorkbook
End Sub

Private Sub SplitWorkbook(wbFrom As Workbook)
    Dim divisions As Object
    Set divisions = GetDivisions(wbFrom, "Итого", 2)
    If divisions.Count = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Dim division As Variant
    For Each division In divisions
        Application.StatusBar = division
        ExtractOneDivision division, wbFrom
    Next
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation, "Разделить книгу"
End Sub

Private Sub ExtractOneDivision(ByVal division As String, wbFrom As Workbook)
    Dim wbTarg As Workbook
    Set wbTarg = Workbooks.Add(1)
    
    Dim sh As Worksheet
    For Each sh In wbFrom.Worksheets
        If sh.Visible = xlSheetVisible Then
            If WorksheetFunction.CountIfs(sh.UsedRange.Columns(1), division) > 0 Then
                ExtractOneDivisionFromSheet division, sh, wbTarg
            End If
        End If
    Next
    
    If wbTarg.Sheets.Count = 1 Then
        wbTarg.Close False
    Else
        Application.DisplayAlerts = False
        wbTarg.Sheets(1).Delete
        Application.DisplayAlerts = True
        
        SaveWorkbook wbTarg, division, wbFrom.Path & "\"
        wbTarg.Close False
    End If
End Sub

Private Sub SaveWorkbook(wb As Workbook, division As String, sPath As String)
    Dim sName As String
    sName = division
    ReplaceSymbols sName
    sName = sName & ".xlsx"
    
    Dim sFull As String
    sFull = sPath & sName
    
    On Error Resume Next
    Workbooks(sName).Close False
    Kill sFull
    On Error GoTo 0
    wb.SaveAs sName
    
End Sub

Private Sub ExtractOneDivisionFromSheet(division As String, shFrom As Worksheet, wbTarg As Workbook)
    shFrom.Copy After:=wbTarg.Sheets(wbTarg.Sheets.Count)
    
    Dim shTarg As Worksheet
    Set shTarg = wbTarg.Sheets(wbTarg.Sheets.Count)
    
    Dim rd As Range
    Set rd = shTarg.UsedRange.Columns(1)
    
    Dim yb As Long
    On Error Resume Next
    yb = WorksheetFunction.Match(division, rd, 0)
    On Error GoTo 0
    If yb = 0 Then Exit Sub
    
    Dim divIndentLevel As Long
    divIndentLevel = rd.Cells(yb, 1).IndentLevel
    
    Dim yf As Long
    For yf = yb + 1 To rd.Rows.Count
        If rd.Cells(yf, 1).IndentLevel <= divIndentLevel Then Exit For
    Next
    yf = yf - 1
    
    If yf < rd.Rows.Count Then
        With shTarg
            .Range(rd.Cells(yf + 1), rd.Cells(rd.Rows.Count, 1)).EntireRow.Delete
        End With
    End If
    
    Dim yy As Long
    For yy = yb - 1 To 1 Step -1
        If rd.Cells(yy, 1).IndentLevel >= divIndentLevel Then
            rd.Cells(yy).EntireRow.Delete
        End If
    Next
    
End Sub

Private Function GetDivisionIndentLevel(rd As Range, division As String) As Long
    Dim yy As Long
    On Error Resume Next
    yy = WorksheetFunction.Match(division, rd, 0)
    On Error GoTo 0
    If yy > 0 Then
        GetDivisionIndentLevel = rd.Cells(yy, 1).IndentLevel
    End If
End Function

Private Function GetDivisions(wb As Workbook, sheetName As String, needIndentLevel As Long) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = wb.Sheets(sheetName)
    On Error GoTo 0
    If Not sh Is Nothing Then
        Dim cl As Range
        For Each cl In sh.UsedRange.Columns(1).Cells
            If cl.IndentLevel = needIndentLevel Then
                dic(cl.Value) = 0
            End If
        Next
    End If
    
    Set GetDivisions = dic
End Function

Private Sub ReplaceSymbols(ss As String)
    Dim vv As Variant
    For Each vv In Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]") '[] недопустимые только в имени листа
        ss = Replace(ss, vv, " ")
    Next
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Перейти

Макрос что бы скрыть столбцов

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

26.04.2024 10:03:43

А так?

Код
Private Sub Worksheet_Change(ByVal Target As Range)

Перейти

[ Закрыто] Снятие значения X c кривой на графике в эксель, необходимо снять значение x с кривой при заданном y

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 26.04.2024 08:58:29 Настаиваете на значении кривой? Задачка сильно упростится, если считать, что точки соединены отрезками прямых.
	Перейти

Как данные в массиве поделить на три равных столбца

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 17:48:12

Код

=ЕСЛИ(СТРОКА()<=ОКРУГЛВВЕРХ((СЧЁТЗ($C:$C)-ЕСЛИОШИБКА(ПОИСКПОЗ(ИНДЕКС(D:D;ПОИСКПОЗ("";D:D;0)-1);$C:$C;0);1))/(СТОЛБЕЦ($H:$H)-СТОЛБЕЦ());0);СМЕЩ($C$1;СТРОКА()+ЕСЛИОШИБКА(ПОИСКПОЗ(ИНДЕКС(D:D;ПОИСКПОЗ("";D:D;0)-1);$C:$C;0);1)-1;0);"")

Изменено: МатросНаЗебре - 26.04.2024 12:25:47 (ОКРУГЛВВЕРХ)

Перейти

Отправка таблицы без запросов в Outlook, Необходимо сохранить копию файла Эксель без запросов и отправить через Outlook

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 16:49:05

Цитата
Excelopfer написал: умные таблицы с запросами. Нельзя их автоматически переделать в таблички

См сообщение #10.

Перейти

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 16:14:37

Цитата
Excelopfer написал: А в новом файле лучше даже без умных таблиц.

Скрытый текст

'v4
Private Sub Workbook_Open()
ThisWorkbook.RefreshAll

Application.Wait Time:=Now + TimeValue("0:02:00")

Dim arrSelSheets(), i As Long
Application.ScreenUpdating = False

Dim SD As String
SD = Date
SD = Format(SD, "YYYY.MM.DD")

Worksheets("Booked_out").Range("a1:e100").Columns.AutoFit
Worksheets("Short").Range("a1:e50").Columns.AutoFit

ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
For i = 1 To UBound(arrSelSheets)
arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
Next

'Worksheets(Array("Booked_out", "Short")).Select
Worksheets("Booked_out").Select
Dim wbFrom As Workbook
Set wbFrom = ActiveWorkbook
'Worksheets(Array("Booked_out", "Short")).Copy
Worksheets("Booked_out").Copy
wbFrom.Worksheets("Short").Copy After:=ActiveWorkbook.Worksheets("Booked_out")
BreakLinks ActiveWorkbook
UnListTables ActiveWorkbook
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & SD & " Check" & ".xlsx"
ActiveWorkbook.Close False
''
' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
' ThisWorkbook.Path & "\" & SD & " Check" & ".pdf", Quality:=xlQualityStandard, _
' IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

Worksheets(arrSelSheets).Select

Application.ScreenUpdating = True
'

Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String

Application.ScreenUpdating = False
On Error Resume Next

Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If

'objOutlookApp.Session.Logon "profile","1234",False, True
Set objMail = objOutlookApp.CreateItem(0) '?
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub

sTo = "Alexander.Levev@sond.com"
sSubject = SD & " Check"
sBody = "Hello, find attached"
sAttachment = ThisWorkbook.Path & "\" & SD & " Check" & ".pdf"

With objMail
.To = sTo
' .CC = "Alexander.Levev@sond.com;Stepan.Baev@Sond.com"
.CC = "Alexey.Ivanov@sond.com"
.BCC = ""
.Subject = sSubject
.Body = sBody

If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.Attachments.Add sAttachment
End If
End If
.Send
End With

Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True

End Sub

Sub BreakLinks(wb As Workbook)
If wb Is Nothing Then Exit Sub
Dim aLinks As Variant
aLinks = wb.LinkSources(xlLinkTypeExcelLinks)
If IsEmpty(aLinks) Then Exit Sub
Dim v As Variant
On Error Resume Next
For Each v In aLinks
wb.BreakLink v, xlLinkTypeExcelLinks
Next
On Error GoTo 0
End Sub

Private Sub UnListTables(wb As Workbook)
Dim sh As Worksheet
Dim tb As ListObject
For Each sh In wb.Worksheets
For Each tb In sh.ListObjects
tb.Unlist
Next
Next
End Sub

Перейти

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 16:08:52

Скрытый текст

'v3
Private Sub Workbook_Open()
ThisWorkbook.RefreshAll

Application.Wait Time:=Now + TimeValue("0:02:00")

Dim arrSelSheets(), i As Long
Application.ScreenUpdating = False

Dim SD As String
SD = Date
SD = Format(SD, "YYYY.MM.DD")

Worksheets("Booked_out").Range("a1:e100").Columns.AutoFit
Worksheets("Short").Range("a1:e50").Columns.AutoFit

ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
For i = 1 To UBound(arrSelSheets)
arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
Next

'Worksheets(Array("Booked_out", "Short")).Select
Worksheets("Booked_out").Select
Dim wbFrom As Workbook
Set wbFrom = ActiveWorkbook
'Worksheets(Array("Booked_out", "Short")).Copy
Worksheets("Booked_out").Copy
wbFrom.Worksheets("Short").Copy After:=ActiveWorkbook.Worksheets("Booked_out")
BreakLinks ActiveWorkbook
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & SD & " Check" & ".xlsx"
ActiveWorkbook.Close False
''
' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
' ThisWorkbook.Path & "\" & SD & " Check" & ".pdf", Quality:=xlQualityStandard, _
' IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

Worksheets(arrSelSheets).Select

Application.ScreenUpdating = True
'

Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String

Application.ScreenUpdating = False
On Error Resume Next

Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If

'objOutlookApp.Session.Logon "profile","1234",False, True
Set objMail = objOutlookApp.CreateItem(0) '?
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub

sTo = "Alexander.Levev@sond.com"
sSubject = SD & " Check"
sBody = "Hello, find attached"
sAttachment = ThisWorkbook.Path & "\" & SD & " Check" & ".pdf"

With objMail
.To = sTo
' .CC = "Alexander.Levev@sond.com;Stepan.Baev@Sond.com"
.CC = "Alexey.Ivanov@sond.com"
.BCC = ""
.Subject = sSubject
.Body = sBody

If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.Attachments.Add sAttachment
End If
End If
.Send
End With

Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True

End Sub

Sub BreakLinks(wb As Workbook)
If wb Is Nothing Then Exit Sub
Dim aLinks As Variant
aLinks = wb.LinkSources(xlLinkTypeExcelLinks)
If IsEmpty(aLinks) Then Exit Sub
Dim v As Variant
On Error Resume Next
For Each v In aLinks
wb.BreakLink v, xlLinkTypeExcelLinks
Next
On Error GoTo 0
End Sub

Перейти

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 15:52:09

Скрытый текст

'v2
Private Sub Workbook_Open()
ThisWorkbook.RefreshAll

Application.Wait Time:=Now + TimeValue("0:02:00")

Dim arrSelSheets(), i As Long
Application.ScreenUpdating = False

Dim SD As String
SD = Date
SD = Format(SD, "YYYY.MM.DD")

Worksheets("Booked_out").Range("a1:e100").Columns.AutoFit
Worksheets("Short").Range("a1:e50").Columns.AutoFit

ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
For i = 1 To UBound(arrSelSheets)
arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
Next

Worksheets(Array("Booked_out", "Short")).Select

Dim wbFrom As Workbook
Set wbFrom = ActiveWorkbook
'Worksheets(Array("Booked_out", "Short")).Copy
Worksheets("Booked_out").Copy
wbFrom.Worksheets("Short").Copy After:=ActiveWorkbook.Worksheets("Booked_out")
BreakLinks ActiveWorkbook
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & SD & " Check" & ".xlsx"
ActiveWorkbook.Close False
''
' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
' ThisWorkbook.Path & "\" & SD & " Check" & ".pdf", Quality:=xlQualityStandard, _
' IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

Worksheets(arrSelSheets).Select

Application.ScreenUpdating = True
'

Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String

Application.ScreenUpdating = False
On Error Resume Next

Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If

'objOutlookApp.Session.Logon "profile","1234",False, True
Set objMail = objOutlookApp.CreateItem(0) '?
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub

sTo = "Alexander.Levev@sond.com"
sSubject = SD & " Check"
sBody = "Hello, find attached"
sAttachment = ThisWorkbook.Path & "\" & SD & " Check" & ".pdf"

With objMail
.To = sTo
' .CC = "Alexander.Levev@sond.com;Stepan.Baev@Sond.com"
.CC = "Alexey.Ivanov@sond.com"
.BCC = ""
.Subject = sSubject
.Body = sBody

If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.Attachments.Add sAttachment
End If
End If
.Send
End With

Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True

End Sub

Sub BreakLinks(wb As Workbook)
If wb Is Nothing Then Exit Sub
Dim aLinks As Variant
aLinks = wb.LinkSources(xlLinkTypeExcelLinks)
If IsEmpty(aLinks) Then Exit Sub
Dim v As Variant
On Error Resume Next
For Each v In aLinks
wb.BreakLink v, xlLinkTypeExcelLinks
Next
On Error GoTo 0
End Sub

Перейти

Удаление пробелов в ячейке, Удаление пробелов в ячейке

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 25.04.2024 15:42:37 Как вставить готовый макрос в рабочую книгу? (e-xcel.ru)
	Перейти

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 14:38:32

Код

Private Sub Workbook_Open()
ThisWorkbook.RefreshAll

Application.Wait Time:=Now + TimeValue("0:02:00")

Dim arrSelSheets(), i As Long
    Application.ScreenUpdating = False
 
 

    SD = Date
    SD = Format(SD, "YYYY.MM.DD")
    
 Worksheets("Booked_out").Range("a1:e100").Columns.AutoFit
 Worksheets("Short").Range("a1:e50").Columns.AutoFit



    ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
    For i = 1 To UBound(arrSelSheets)
        arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
    Next
     
 
    Worksheets(Array("Booked_out", "Short")).Select
    
    Worksheets(Array("Booked_out", "Short")).Copy
    BreakLinks ActiveWorkbook
    ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & SD & " Check" & ".xlsx"
    ActiveWorkbook.Close False
''
'    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
'        ThisWorkbook.Path & "\" & SD & " Check" & ".pdf", Quality:=xlQualityStandard, _
'        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    Worksheets(arrSelSheets).Select

    Application.ScreenUpdating = True
'
    
    
    
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    On Error Resume Next

    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
   
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   '?
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = "Alexander.Levev@sond.com"
    sSubject = SD & " Check"
    sBody = "Hello, find attached"
    sAttachment = ThisWorkbook.Path & "\" & SD & " Check" & ".pdf"
 
   
    With objMail
        .To = sTo
'        .CC = "Alexander.Levev@sond.com;Stepan.Baev@Sond.com"
        .CC = "Alexey.Ivanov@sond.com"
        .BCC = ""
        .Subject = sSubject
        .Body = sBody
        
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment
            End If
        End If
        .Send
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
    
    
    
    
    
    


End Sub

Sub BreakLinks(wb As Workbook)
    If wb Is Nothing Then Exit Sub
    Dim aLinks As Variant
    aLinks = wb.LinkSources(xlLinkTypeExcelLinks)
    If IsEmpty(aLinks) Then Exit Sub
    Dim v As Variant
    On Error Resume Next
        For Each v In aLinks
            wb.BreakLink v, xlLinkTypeExcelLinks
        Next
    On Error GoTo 0
End Sub

Перейти

Проверить содержит ли строка определённые символы, Формула проверка надежности пароля

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 25.04.2024 11:31:36 Всё норм. Формула требуется для противодействия злобному гению(ученику пятого класса Андрею Иванову), обладающего знаниями, позволяющими взломать пароль Изменено: МатросНаЗебре - 25.04.2024 11:32:21
	Перейти

Проверить содержит ли строка определённые символы, Формула проверка надежности пароля

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 11:14:08

Без вспомогательного столбца. По крайней мере, без вспомогательного столбца не на этапе составления формулы )

Код

=ИЛИ(
НЕ(ЕОШ(НАЙТИ("!";$C$4)));
НЕ(ЕОШ(НАЙТИ("""";$C$4)));
НЕ(ЕОШ(НАЙТИ("#";$C$4)));
НЕ(ЕОШ(НАЙТИ("$";$C$4)));
НЕ(ЕОШ(НАЙТИ("%";$C$4)));
НЕ(ЕОШ(НАЙТИ("&";$C$4)));
НЕ(ЕОШ(НАЙТИ("'";$C$4)));
НЕ(ЕОШ(НАЙТИ("(";$C$4)));
НЕ(ЕОШ(НАЙТИ(")";$C$4)));
НЕ(ЕОШ(НАЙТИ("*";$C$4)));
НЕ(ЕОШ(НАЙТИ("+";$C$4)));
НЕ(ЕОШ(НАЙТИ(",";$C$4)));
НЕ(ЕОШ(НАЙТИ("-";$C$4)));
НЕ(ЕОШ(НАЙТИ(".";$C$4)));
НЕ(ЕОШ(НАЙТИ("/";$C$4)));
НЕ(ЕОШ(НАЙТИ(":";$C$4)));
НЕ(ЕОШ(НАЙТИ(";";$C$4)));
НЕ(ЕОШ(НАЙТИ("<";$C$4)));
НЕ(ЕОШ(НАЙТИ("=";$C$4)));
НЕ(ЕОШ(НАЙТИ(">";$C$4)));
НЕ(ЕОШ(НАЙТИ("?";$C$4)));
НЕ(ЕОШ(НАЙТИ("@";$C$4)));
НЕ(ЕОШ(НАЙТИ("[";$C$4)));
НЕ(ЕОШ(НАЙТИ("\";$C$4)));
НЕ(ЕОШ(НАЙТИ("]";$C$4)));
НЕ(ЕОШ(НАЙТИ("^";$C$4)));
НЕ(ЕОШ(НАЙТИ("{";$C$4)));
НЕ(ЕОШ(НАЙТИ("|";$C$4)));
НЕ(ЕОШ(НАЙТИ("}";$C$4)));
НЕ(ЕОШ(НАЙТИ("~";$C$4)));
)

Перейти

Проверить содержит ли строка определённые символы, Формула проверка надежности пароля

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 11:08:10

Допустим символы находятся в диапазоне A1:A30, тогда формулу вставляем в диапазон B1:B30

Код
=НЕ(ЕОШ(НАЙТИ(A1;$C$4)))

Итоговая формула, возвращающая, содержит ли строка символы, будет:

Код
=ИЛИ($B$1:B$30)

Вариант названия темы:
Формула, показывающая, содержит ли строка/пароль определённые символы

Перейти

Цикличный перебор значений в таблице по строкам, по пяти критериям, и в конце посчитать сумму.

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 25.04.2024 09:18:03 Выложите файл, как вы вставили формулы из сообщения #13.
	Перейти

Пересчёт координат точек для построения контурной карты РФ

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 09:15:06

Как можно было бы сделать.
- Сделать таблицу соответствия географических координат и координат на экране. Например, через каждые 5000 км по параллелям и меридианам.
- Новые координаты на экране получать используя эти данные, например, с помощью линейной аппроксимации.

PS Точность метода может оказаться небольшой - на дубль в платной ветке не тороплюсь откликаться. Возможно, кто-то предложит вариант лучше.

Перейти

Вставка имени листа в ячейку

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

25.04.2024 09:04:31

аА так?

Код

=ЕСЛИ(ЕОШ(НАЙТИ("]";ЯЧЕЙКА("filename")));СЖПРОБЕЛЫ(ЛЕВСИМВ(ПОДСТАВИТЬ(СЖПРОБЕЛЫ(ПРАВСИМВ(ПОДСТАВИТЬ(ЯЧЕЙКА("filename";A1);"\";ПОВТОР("  ";255));255));".xls";ПОВТОР("  ";255));255));ПРАВСИМВ(ЯЧЕЙКА("filename";A1);ДЛСТР(ЯЧЕЙКА("filename"))-НАЙТИ("]";ЯЧЕЙКА("filename"))))

Перейти

Перевод данных из 36-ричной системы счисления в 10-ричную, нужна формула, или как ее сделать.

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 24.04.2024 16:47:16 Пользовательская функция для перевода из различных систем счисления (planetaexcel.ru) Вариант через пользовательскую функцию.
	Перейти

Поиск по части строки. Из строки "Фамилия Имя Отчество" найти в столбце "Фамилия", списки в Excel

МатросНаЗебре

Пользователь

Сообщений: 6522 Регистрация: 05.02.2014

24.04.2024 16:11:43

Код
C1:C2 =ЛЕВСИМВ(A1;НАЙТИ(" ";A1)-1) D1:D2 =СЧЁТЕСЛИМН(B:B;C:C) E1:E6 =СЧЁТЕСЛИМН(C:C;B:B)

Вариант названия темы
Поиск по части строки. Из строки "Фамилия Имя Отчество" найти в столбце "Фамилия".

Перейти

Цикличный перебор значений в таблице по строкам, по пяти критериям, и в конце посчитать сумму.

МатросНаЗебре Пользователь Сообщений: 6522 Регистрация: 05.02.2014	# 24.04.2024 16:04:49 Ошибка #ПЕРЕНОС - у меня не воспроизводится.
	Перейти