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

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

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

Сообщений: 6508 Регистрация: 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);"")

Перейти

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

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

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

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

25.04.2024 16:49:05

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

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

Перейти

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

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

Сообщений: 6508 Регистрация: 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

Перейти

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

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

Сообщений: 6508 Регистрация: 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

Перейти

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

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

Сообщений: 6508 Регистрация: 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

Перейти

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

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

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

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

Сообщений: 6508 Регистрация: 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

Перейти

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

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

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

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

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

Сообщений: 6508 Регистрация: 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)));
)

Перейти

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

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

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

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

25.04.2024 11:08:10

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

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

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

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

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

Перейти

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

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

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

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

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

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

25.04.2024 09:15:06

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

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

Перейти

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

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

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

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

25.04.2024 09:04:31

аА так?

Код

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

Перейти

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

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

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

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

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

Сообщений: 6508 Регистрация: 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)

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

Перейти

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

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

Добавление данных в таблицу из двух других, описание условий в файле

МатросНаЗебре Пользователь Сообщений: 6508 Регистрация: 05.02.2014	# 24.04.2024 15:16:20 Сделал. Оплату получил.
	Перейти

Замена части формулы в таблице, Замена части формулы в таблице

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

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

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

24.04.2024 14:39:23

Код

Sub ReplaceFormula()
'Выделите ячейки. Запустите макрос.

    Const formula_was = "ЕСЛИ($AC$1=""ДВС"";СУММЕСЛИМН('Расстановка ГШО'!$BI:$BI;'Расстановка ГШО'!$Q:$Q;$C5)/('Расстановка ГШО'!$BI$2-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0)))*($D5-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0)));СУММЕСЛИМН('Расстановка ГШО'!$BJ:$BJ;'Расстановка ГШО'!$Q:$Q;$C5)/('Расстановка ГШО'!$BI$2-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0)))*($D5-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0))))"
    Const formula_must = "A2"

    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim cl As Range
    For Each cl In Selection.SpecialCells(xlCellTypeFormulas).Cells
        If InStr(cl.FormulaLocal, formula_was) > 0 Then
            cl.FormulaLocal = Replace(cl.FormulaLocal, formula_was, formula_must)
        End If
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Перейти

Добавление данных в таблицу из двух других, описание условий в файле

МатросНаЗебре Пользователь Сообщений: 6508 Регистрация: 05.02.2014	# 24.04.2024 14:07:17 Нет проблем, бывает )
	Перейти

Добавление данных в таблицу из двух других, описание условий в файле

МатросНаЗебре Пользователь Сообщений: 6508 Регистрация: 05.02.2014	# 24.04.2024 13:00:49 Хммм... Ладно, покинул чат.
	Перейти

Добавление данных в таблицу из двух других, описание условий в файле

МатросНаЗебре Пользователь Сообщений: 6508 Регистрация: 05.02.2014	# 24.04.2024 12:28:55 Могу предложить решение макросом.
	Перейти

Выбрать цифры из числа

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

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

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

24.04.2024 12:07:44

Код
=ПСТР(A1;3;2) =ЗНАЧЕН(ПСТР(A1;3;2))

Перейти

Создание множества листов в одном документе, Создание множества листов в одном документе

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

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

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

24.04.2024 12:05:58

Код
Sub Макрос1() Dim ii As Long For ii = 1 To 100 ActiveSheet.Copy After:=Sheets(Sheets.Count) Next End Sub

Перейти

Поиск точного числа в интервале

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

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

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

24.04.2024 12:02:50

Код

=(ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;6)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6))/((ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;2)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2)))*(N4-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2))+ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6)

Перейти

Поиск точного числа в интервале

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

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

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

24.04.2024 11:47:08

Вы ж получили значение. Вам это одной формулой надо?

Код

=(ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;6)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6))/((ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;2)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2)))*(N4-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2))+ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6)

Изменено: МатросНаЗебре - 24.04.2024 11:50:24

Перейти

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

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

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

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

24.04.2024 11:30:03

Код
O5:O20 =O4+(СЧЁТЕСЛИМН(C$3:C4;C5;E$3:E4;E5;G$3:G4;G5;I$3:I4;I5)=0)

В ячейку O5 вставляете формулу =O4+(СЧЁТЕСЛИМН(C$3:C4;C5;E$3:E4;E5;G$3:G4;G5;I$3:I4;I5)=0).
Тяните до ячейки O20.

Перейти

Не работает надстройка

МатросНаЗебре Пользователь Сообщений: 6508 Регистрация: 05.02.2014	# 24.04.2024 10:30:45 А если подключить библиотеку MS Forms 2.0 c:\windows\system32\FM20.DLL
	Перейти

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

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

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

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

24.04.2024 09:44:18

Для файла из сообщения #5 формулы примут вид:

Код

O5:O20    =O4+(СЧЁТЕСЛИМН(C$3:C4;C5;E$3:E4;E5;G$3:G4;G5;I$3:I4;I5)=0)
B24:C39    =ЕСЛИОШИБКА(ИНДЕКС(СМЕЩ($A$5:$A$20;0;ПОИСКПОЗ($23:$23;$4:$4;0)-1);ПОИСКПОЗ($A:$A;$O$5:$O$20;0));"")
E24:G39    =ЕСЛИОШИБКА(ИНДЕКС(СМЕЩ($A$5:$A$20;0;ПОИСКПОЗ($23:$23;$4:$4;0)-1);ПОИСКПОЗ($A:$A;$O$5:$O$20;0));"")
H24:H39    =СУММЕСЛИМН($L$5:$L$20;$C$5:$C$20;$C$23:$C$39;$E$5:$E$20;$E$23:$E$39;$G$5:$G$20;$F$23:$F$39;$I$5:$I$20;$G$23:$G$39)

Перейти

Вставить символы в начале и конце каждого абзаца

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

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

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

23.04.2024 17:09:45

Допустим, что абзацы на рисунке отделены символом 10, тогда следует применить формулу:

Код
="@"&ПОДСТАВИТЬ(F1;СИМВОЛ(10);"@"&СИМВОЛ(10)&"@")&"@"

Перейти

Сравнение диапазонов на соответствие с возвратом текста после разделителя, Нужно сравнить диапазоны на совпадение и записать текст после разделителя в ячейку формулы

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

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

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

23.04.2024 15:57:05

Код

=ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($E2;ПОИСК(":";$E2)-1));ПРАВСИМВ($E2;ДЛСТР($E2)-ПОИСК(":";$E2));"");"")&
ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($F2;ПОИСК(":";$F2)-1));ПРАВСИМВ($F2;ДЛСТР($F2)-ПОИСК(":";$F2));"");"")&
ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($G2;ПОИСК(":";$G2)-1));ПРАВСИМВ($G2;ДЛСТР($G2)-ПОИСК(":";$G2));"");"")&
ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($H2;ПОИСК(":";$H2)-1));ПРАВСИМВ($H2;ДЛСТР($H2)-ПОИСК(":";$H2));"");"")

Перейти