Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » МатросНаЗебре
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 224 След.
Внести данные из столбца, так чтобы не повторялись со старыми значениями
 
#
23.05.2024 13:00:31
Код
B3:B124    =ВПР(СТРОКА(B1);C:D;2;0)
C3:C124    =C2+(СЧЁТЕСЛИМН(A:A;D:D)=0)
 
Перейти    
Формат Времени, Создание времени
 
#
23.05.2024 12:30:08
Код
=ВРЕМЗНАЧ("11:05")+СЛЧИС()*(ВРЕМЗНАЧ("12:20")-ВРЕМЗНАЧ("11:05"))
Здесь принято, один вопрос - одна тема.
В качестве названия темы подойдёт вопрос из сообщения #1
"Как сделать случайное время в диапазоне c 11:05 до 12:20".
 
Перейти    
Обновление данных в таблице по дате, Обновление данных в таблице по дате с функцией ВПР
 
#
23.05.2024 12:23:52
Код
=ЕСЛИОШИБКА(ВПР($A6;Лист2!A9:R15;ПОИСКПОЗ(ТЕКСТ($B$1;"ДД.ММ.ГГГГ");Лист2!$9:$9;0)-1;0);0)
 
Перейти    
Перенос графиков на новый лист
 
#
23.05.2024 12:07:05
Цитата
написал:
надо заменить Лист1 на имя листа, c которого изначально все графики брала?
Верно.
Цитата
написал:
И макрос запускать на остальных листах, а не на изначальном, да?
Нет. Достаточно запустить один раз. Но, если решите так сделать, хуже не станет.
 
Перейти    
Перенос графиков на новый лист
 
#
23.05.2024 12:00:48
Без файла хоть в каком-нибудь виде сложно понять, почему "ничего не происходит".
 
Перейти    
Перенос графиков на новый лист
 
#
23.05.2024 11:55:50
Цитата
написал:
Вручную займет часа 4 - это ужас.
Готов сделать за Вас при оплате за половину этого времени.
 
Перейти    
Перенос графиков на новый лист
 
#
23.05.2024 11:05:21
Код
Sub ReplaceSource()
    Const BASE_SHEET = "Лист1"
    
    Dim ss As String
    Dim ch As ChartObject
    Dim fs As FullSeriesCollection
    Dim ifs As Long
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> BASE_SHEET Then
            For Each ch In sh.ChartObjects
                For ifs = 1 To ch.Chart.FullSeriesCollection.Count
                    ss = ch.Chart.FullSeriesCollection(ifs).Formula
                    ss = Replace(ss, BASE_SHEET & "!", "'" & sh.Name & "'!")
                    ss = Replace(ss, "'" & BASE_SHEET & "'!", "'" & sh.Name & "'!")
                    ss = Replace(ss, "''", "'")
                    ch.Chart.FullSeriesCollection(ifs).Formula = ss
                Next
            Next
        End If
    Next
End Sub
 
Перейти    
Вставить макросом строки промежуточных итогов между блоками строк, макрос для проверки таблицы и добавления строк
 
#
23.05.2024 09:50:59
Скрытый текст
МОДЕРАТОРАМ
Вариант названия темы:
Вставить макросом строки промежуточных итогов между блоками строк
 
Перейти    
Последовательное изменение текста на кнопке по её нажатию, Нужен макрос позволяющий по нажатии на копку менять текст в ней. Тут важное замечание - последовательно.
 
#
23.05.2024 08:55:30
Чем это отличается от предложенного варианта в сообщении #4? Вопрос, не требующий ответа.
 
Перейти    
Найти и заменить только заглавные буквы
 
#
22.05.2024 17:40:59
Параметры-Учитывать регистр
 
Перейти    
Найти и заменить только заглавные буквы
 
#
22.05.2024 17:39:40
Учитывать регистр
9aed27e257cd3d2cee29188d2c7ac62d.png (477×241) (excel-home.ru)
Изменено: МатросНаЗебре - 22.05.2024 17:43:41
 
Перейти    
Копирование данных из открытой книги с разными названиями, Копирование данных из открытой книги в постоянную книгу в определенный лист, в выделенную ячейку
 
#
22.05.2024 17:38:42
Код
Sub Из_МАРШРУТА_с_любовью()
    From_marsh True
End Sub

Sub Из_МАРШРУТА_без_любви()
    From_marsh False
End Sub

Private Sub From_marsh(checkPresence As Boolean)
    Dim shMarsh As Worksheet: Set shMarsh = GetSheet("МАРШРУТ"): If shMarsh Is Nothing Then Exit Sub
    Dim shCatal As Worksheet: Set shCatal = GetSheet("КАТАЛОГ"): If shCatal Is Nothing Then Exit Sub
    
    With shCatal
        If checkPresence Then
            If WorksheetFunction.CountIfs(.Columns(1), shMarsh.Range("A5").Value) > 0 Then Exit Sub
        End If
        
        Dim arr As Variant
        arr = myTranspose(shMarsh.Range("H11:H125"))
        
        Dim yc As Long
        yc = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Cells(yc, 1).Value = shMarsh.Range("A5").Value
        .Cells(yc, 2).Resize(1, UBound(arr, 2)).Value = arr
                    
        Application.Goto .Cells(yc, 1)
    End With
End Sub

Private Function myTranspose(rr As Range) As Variant
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr, 1))
    
    Dim ya As Long
    Dim xa As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            brr(xa, ya) = arr(ya, xa)
        Next
    Next
    myTranspose = brr
End Function

Private Function GetSheet(sheetName As String) As Worksheet
    Dim sh As Worksheet
    Dim index_wb As Long
    
    On Error Resume Next
    For index_wb = Workbooks.Count To 1 Step -1
        Set sh = Workbooks(index_wb).Worksheets(sheetName)
        If Not sh Is Nothing Then
            Set GetSheet = sh
            Exit For
        End If
    Next
    
    On Error GoTo 0
End Function
 
Перейти    
Создать все варианты предложений из трех колонок слов
 
#
22.05.2024 16:11:06
Код
=СМЕЩ($A$1;ОСТАТ(ЦЕЛОЕ((СТРОКА()-1)/(СЧЁТЗ(A:A)*СЧЁТЗ(B:B)));СЧЁТЗ(A:A));0)&
СМЕЩ($B$1;ОСТАТ(ЦЕЛОЕ((СТРОКА()-1)/СЧЁТЗ(B:B));СЧЁТЗ(B:B));0)&
СМЕЩ($C$1;ОСТАТ(СТРОКА()-1;СЧЁТЗ(C:C));0)
 
Перейти    
Создать все варианты предложений из трех колонок слов
 
#
22.05.2024 16:04:20
Код
=СМЕЩ($A$1;ОСТАТ(ЦЕЛОЕ((СТРОКА()-1)/(СЧЁТЗ(A:A)*СЧЁТЗ(B:B)));СЧЁТЗ(A:A)*СЧЁТЗ(B:B));0)&
СМЕЩ($B$1;ОСТАТ(ЦЕЛОЕ((СТРОКА()-1)/СЧЁТЗ(B:B));СЧЁТЗ(B:B));0)&
СМЕЩ($C$1;ОСТАТ(СТРОКА()-1;СЧЁТЗ(C:C));0)
В строке 217 не начинает перебор заново.
Изменено: МатросНаЗебре - 22.05.2024 16:11:50
 
Перейти    
Копирование данных из открытой книги с разными названиями, Копирование данных из открытой книги в постоянную книгу в определенный лист, в выделенную ячейку
 
#
22.05.2024 14:01:17
Код
Sub Из_МАРШРУТА_с_любовью()
    Dim shMarsh As Worksheet: Set shMarsh = GetSheet("МАРШРУТ"): If shMarsh Is Nothing Then Exit Sub
    Dim shCatal As Worksheet: Set shCatal = GetSheet("КАТАЛОГ"): If shCatal Is Nothing Then Exit Sub
    
    With shCatal
        If WorksheetFunction.CountIfs(.Columns(1), shMarsh.Range("A5").Value) = 0 Then
            Dim arr As Variant
            arr = myTranspose(shMarsh.Range("H11:H125"))
            
            Dim yc As Long
            yc = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            .Cells(yc, 1).Value = shMarsh.Range("A5").Value
            .Cells(yc, 2).Resize(1, UBound(arr, 2)).Value = arr
                        
            Application.Goto .Cells(yc, 1)
        End If
    End With
    
End Sub

Private Function myTranspose(rr As Range) As Variant
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr, 1))
    
    Dim ya As Long
    Dim xa As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            brr(xa, ya) = arr(ya, xa)
        Next
    Next
    myTranspose = brr
End Function

Private Function GetSheet(sheetName As String) As Worksheet
    Dim sh As Worksheet
    Dim index_wb As Long
    
    On Error Resume Next
    For index_wb = Workbooks.Count To 1 Step -1
        Set sh = Workbooks(index_wb).Worksheets(sheetName)
        If Not sh Is Nothing Then
            Set GetSheet = sh
            Exit For
        End If
    Next
    
    On Error GoTo 0
End Function
 
Перейти    
Считать сумму цифр , без учета букв
 
#
22.05.2024 13:53:21
Евгений Король, ваша задача совсем про другое.
Код
=СУММАЯЧЕЕК(D95:AH95)
Код
Function СУММАЯЧЕЕК(диапазон As Range) As Double
    Dim res As Double
    Dim cl As Range
    For Each cl In диапазон.Cells
        res = res + СУММАЦИФР(cl.Value)
    Next
    СУММАЯЧЕЕК = res
End Function

Function СУММАЦИФР(строка As String) As Double
    If строка = "" Then Exit Function
    
    Dim arr As Variant
    ReDim arr(1 To Len(строка))
    
    Dim ya As Long
    For ya = 1 To UBound(arr)
        arr(ya) = Mid(строка, ya, 1)
        If arr(ya) Like "#" Then
        ElseIf arr(ya) Like "[.,]" Then
        Else
            arr(ya) = " "
        End If
    Next
    
    Dim ss As String
    ss = Join(arr, "")
    ss = Trim(ss)
    Do
        If InStr(ss, "  ") = 0 Then Exit Do
        ss = Replace(ss, "  ", " ")
    Loop
    
    arr = Split(ss, " ")
    Dim res As Double
    For ya = LBound(arr) To UBound(arr)
        If IsNumeric(arr(ya)) Then res = res + CDbl(arr(ya))
    Next
    
    СУММАЦИФР = res
End Function
 
Перейти    
Считать сумму цифр , без учета букв
 
#
22.05.2024 13:27:04
Вариант через пользовательскую функцию.
Код
Function СУММАЦИФР(строка As String) As Double
    If строка = "" Then Exit Function
    
    Dim arr As Variant
    ReDim arr(1 To Len(строка))
    
    Dim ya As Long
    For ya = 1 To UBound(arr)
        arr(ya) = Mid(строка, ya, 1)
        If arr(ya) Like "#" Then
        ElseIf arr(ya) Like "[.,]" Then
        Else
            arr(ya) = " "
        End If
    Next
    
    Dim ss As String
    ss = Join(arr, "")
    ss = Trim(ss)
    Do
        If InStr(ss, "  ") = 0 Then Exit Do
        ss = Replace(ss, "  ", " ")
    Loop
    
    arr = Split(ss, " ")
    Dim res As Double
    For ya = LBound(arr) To UBound(arr)
        If IsNumeric(arr(ya)) Then res = res + CDbl(arr(ya))
    Next
    
    СУММАЦИФР = res
End Function
 
Перейти    
Замена #N/D во формуле на пусто
 
#
22.05.2024 12:57:18
Код
ЕСЛИОШИБКА(ВПР();"")
 
Перейти    
Как использовать командную строку?, VBA. How to use Cmd. Function «Shell()», Object «WshShell» and others
 
#
22.05.2024 12:28:00
Цитата
написал:
вынужден закрыть здесь обсуждение
Как-то зря модераторы прижали эту тему и тему с архивами. Тема-то интересная. Было бы неплохо, чтоб на форуме можно было бы почитать про работу с командной строкой из Excel.
 
Перейти    
Последовательное извлечение всех чисел из текста ячейки., Необходимо из текста ячейки последовательно извлечь числовые значения в заданном порядке.
 
#
22.05.2024 11:38:49
Вариант через пользовательскую функцию.
В ячейку C3 вставьте формулу
Код
=ЧИСЛА($B3;СТОЛБЕЦ(A:A))
Код
Function ЧИСЛА(строка As String, индекс As Long) As Variant
    ЧИСЛА = Empty
    If строка = "" Then Exit Function
    
    Dim arr As Variant
    ReDim arr(1 To Len(строка))
    
    Dim ya As Long
    For ya = 1 To UBound(arr)
        arr(ya) = Mid(строка, ya, 1)
        If arr(ya) Like "#" Then
        ElseIf arr(ya) Like "[()х]" Then
        Else
            arr(ya) = " "
        End If
    Next
    
    Dim ss As String
    ss = Join(arr, "")
    ss = Trim(ss)
    Do
        If InStr(ss, "  ") = 0 Then Exit Do
        ss = Replace(ss, "  ", " ")
    Loop
    arr = Split(ss, "х")
    Dim brr As Variant
    ReDim brr(LBound(arr) To UBound(arr))
    For ya = LBound(arr) To UBound(arr)
        If InStr(arr(ya), ")") > 0 Then arr(ya) = Replace(arr(ya), ")", "(")
        If InStr(arr(ya), "(") > 0 Then
            brr(ya) = Split(arr(ya), "(")
        Else
            brr(ya) = Array(arr(ya))
        End If
    Next
        
    Dim ii As Long
    Dim yb As Long
    
    Dim crr As Variant
    ReDim crr(LBound(brr) To UBound(brr), 1 To 2)
    For yb = LBound(brr) To UBound(brr)
        arr = brr(yb)
        ii = 0
        For ya = LBound(arr) To UBound(arr)
            If arr(ya) <> "" Then
                ii = ii + 1
                If ii <= UBound(crr, 2) Then crr(yb, ii) = arr(ya)
            End If
        Next
    Next
    
    ii = 0
    Dim yc As Long
    Dim xc As Long
    For yc = LBound(crr, 1) To UBound(crr, 1)
        For xc = LBound(crr, 2) To UBound(crr, 2)
            ii = ii + 1
            If ii = индекс Then
                If IsEmpty(crr(yc, xc)) Then
                    ЧИСЛА = ""
                ElseIf IsNumeric(crr(yc, xc)) Then
                    ЧИСЛА = CLng(crr(yc, xc))
                Else
                    ЧИСЛА = crr(yc, xc)
                End If
                Exit Function
            End If
        Next
    Next
    
End Function
 
Перейти    
Объединение строчек по столбцу наименовани
 
#
22.05.2024 10:20:02
Код
Sub MergeSelection()
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    Dim cl As Range
    For Each cl In rr.Cells
        MergeCell cl
    Next
End Sub

Private Sub MergeCell(cl As Range)
    If cl.Value = "" Then Exit Sub
    If IsNumeric(cl.Value) Then Exit Sub
    Dim xx As Long
    If cl.Cells(2, 1).Value Like cl.Value & "*" Then
        cl.Value = cl.Cells(2, 1).Value
        For xx = cl.Parent.UsedRange.Column To cl.Parent.UsedRange.Column + cl.Parent.UsedRange.Columns.Count - 1
            If xx = cl.Parent.UsedRange.Column Then
                Cells(cl.Row, xx).Value = myMax(Cells(cl.Row, xx)) + 1
                Cells(cl.Row + 1, xx).Value = Empty
            ElseIf IsNumeric(Cells(cl.Row, xx).Value) And IsNumeric(Cells(cl.Row + 1, xx).Value) Then
                Cells(cl.Row, xx).Value = Cells(cl.Row, xx).Value + Cells(cl.Row + 1, xx).Value
            End If
            Application.DisplayAlerts = False
            Cells(cl.Row, xx).Resize(2, 1).Merge
            Application.DisplayAlerts = True
        Next
    Else
        xx = cl.Parent.UsedRange.Column
        Cells(cl.Row, xx).Value = myMax(Cells(cl.Row, xx)) + 1
    End If
End Sub

Private Function myMax(cl As Range) As Long
    On Error Resume Next
    myMax = WorksheetFunction.Max(Range(Cells(1, cl.Column), Cells(cl.Row - 1, cl.Column)))
    On Error GoTo 0
End Function
Выделите ячейки в столбце "Наименование", запустите макрос MergeSelection.
 
Перейти    
Ограничение ввода в ячейку по количеству и виду символов
 
#
22.05.2024 09:46:16
Или в условное форматирование
Код
=СЧЁТЕСЛИМН(A1;"??000000")=0
или в проверку данных. Данные-Проверка данных-Тип данных-Другой-Формула
Код
=СЧЁТЕСЛИМН(A1;"??000000")=1
 
Перейти    
Последовательное изменение текста на кнопке по её нажатию, Нужен макрос позволяющий по нажатии на копку менять текст в ней. Тут важное замечание - последовательно.
 
#
22.05.2024 09:40:55
Код
    With ActiveSheet.DrawingObjects(Application.Caller).Characters
        Select Case .Text
        Case "1": .Text = "2"
        Case "2": .Text = "3"
        Case "3": .Text = "1"
        Case Else: .Text = "1"
        End Select
    End With
 
Перейти    
Как сделать список людей с формулами и некоторыми условиями
 
#
22.05.2024 08:57:42
Код
=ЕСЛИ(ДЕНЬНЕД([@Дата];2)=6;"";ЕСЛИ(ВПР(ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(ЕСЛИ(ДЕНЬНЕД([@Дата];2)=7;B3;B4);Таблица1[Имена];0)+0;СЧЁТЗ(Таблица1[Имена]))+1);Таблица1[[Имена]:[Дата выхода]];3;0)<=[@Дата];
ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(ЕСЛИ(ДЕНЬНЕД([@Дата];2)=7;B3;B4);Таблица1[Имена];0)+0;СЧЁТЗ(Таблица1[Имена]))+1);
ЕСЛИ(ВПР(ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+1;СЧЁТЗ(Таблица1[Имена]))+1);Таблица1[[Имена]:[Дата выхода]];3;0)<=[@Дата];
ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(ЕСЛИ(ДЕНЬНЕД([@Дата];2)=7;B3;B4);Таблица1[Имена];0)+1;СЧЁТЗ(Таблица1[Имена]))+1);
ЕСЛИ(ВПР(ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(ЕСЛИ(ДЕНЬНЕД([@Дата];2)=7;B3;B4);Таблица1[Имена];0)+2;СЧЁТЗ(Таблица1[Имена]))+1);Таблица1[[Имена]:[Дата выхода]];3;0)<=[@Дата];
ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(ЕСЛИ(ДЕНЬНЕД([@Дата];2)=7;B3;B4);Таблица1[Имена];0)+3;СЧЁТЗ(Таблица1[Имена]))+1);
ЕСЛИ(ВПР(ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+0;СЧЁТЗ(Таблица1[Имена]))+1);Таблица1[[Имена]:[Дата выхода]];3;0)<=[@Дата];
ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(ЕСЛИ(ДЕНЬНЕД([@Дата];2)=7;B3;B4);Таблица1[Имена];0)+3;СЧЁТЗ(Таблица1[Имена]))+1);
"")))))
 
Перейти    
Как сделать список людей с формулами и некоторыми условиями
 
#
21.05.2024 17:41:19
Вариант через пользовательскую функцию.
Код
Function ПОСЛЕ(Имя As String, Дата As Date) As String
    Dim aName As Variant
    Dim aDate As Variant
    With Sheets("Список").ListObjects("Таблица1")
        aName = .ListColumns("Имена").DataBodyRange.Value
        aDate = .ListColumns("Дата выхода").DataBodyRange.Value
    End With
    
    Dim ya As Long
    For ya = 1 To UBound(aName, 1)
        If aName(ya, 1) = Имя Then
            Exit For
        End If
    Next
    If ya > UBound(aName, 1) Then ya = 0
    
    Dim ii As Long
    Dim yb As Long
    yb = ya + 1
    For ii = 1 To UBound(aName, 1)
        If yb > UBound(aName, 1) Then yb = 1
        If Дата >= aDate(yb, 1) Then
            ПОСЛЕ = aName(yb, 1)
            Exit Function
        End If
        yb = yb + 1
    Next
    ПОСЛЕ = aName(1, 1)
End Function

В ячейку B4 вставить формулу:
Код
=После(B3;A4)
 
Перейти    
Как сделать список людей с формулами и некоторыми условиями
 
#
21.05.2024 17:19:04
Код
=ЕСЛИ(ВПР(ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+0;СЧЁТЗ(Таблица1[Имена]))+1);Таблица1[[Имена]:[Дата выхода]];3;0)<=[@Дата];
ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+0;СЧЁТЗ(Таблица1[Имена]))+1);
ЕСЛИ(ВПР(ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+1;СЧЁТЗ(Таблица1[Имена]))+1);Таблица1[[Имена]:[Дата выхода]];3;0)<=[@Дата];
ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+1;СЧЁТЗ(Таблица1[Имена]))+1);
ЕСЛИ(ВПР(ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+2;СЧЁТЗ(Таблица1[Имена]))+1);Таблица1[[Имена]:[Дата выхода]];3;0)<=[@Дата];
ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+3;СЧЁТЗ(Таблица1[Имена]))+1);
ЕСЛИ(ВПР(ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+0;СЧЁТЗ(Таблица1[Имена]))+1);Таблица1[[Имена]:[Дата выхода]];3;0)<=[@Дата];
ИНДЕКС(Таблица1[Имена];ОСТАТ(ПОИСКПОЗ(B4;Таблица1[Имена];0)+3;СЧЁТЗ(Таблица1[Имена]))+1);
""))))
B5 и протянуть.
 
Перейти    
Суммирование по диапазону, с замещением значений из соседнего столбца, при этом вычитание значений которые заменены
 
#
21.05.2024 16:19:00
Код
=СУММЕСЛИМН(E:E;C:C;I:I;D:D;"")+СУММЕСЛИМН(E:E;D:D;I:I)
 
Перейти    
Как взять со столбца (длинный текст) только нужные цифры? К примеру в одном столбце большой текст с цифрами., Как взять со столбца (длинный текст) только нужные цифры?
 
#
21.05.2024 16:14:40
Код
=ЗНАЧЕН(ЛЕВСИМВ(ПСТР(A8;НАЙТИ("общей площадью ";A8)+ДЛСТР("общей площадью ");ДЛСТР(A8));НАЙТИ(" ";ПСТР(A8;НАЙТИ("общей площадью ";A8)+ДЛСТР("общей площадью ");ДЛСТР(A8)))-1))
 
Перейти    
Копирование данных из открытой книги с разными названиями, Копирование данных из открытой книги в постоянную книгу в определенный лист, в выделенную ячейку
 
#
21.05.2024 16:09:47
Код
Sub Из_МАРШРУТА_с_любовью()
    Dim shMarsh As Worksheet: Set shMarsh = GetSheet("МАРШРУТ"): If shMarsh Is Nothing Then Exit Sub
    Dim shCatal As Worksheet: Set shCatal = GetSheet("КАТАЛОГ"): If shCatal Is Nothing Then Exit Sub
    
    Dim arr As Variant
    arr = myTranspose(shMarsh.Range("H11:H125"))
    
    shCatal.Parent.Activate
    shCatal.Activate
    With ActiveCell.EntireRow
        .Cells(1, 1).Value = shMarsh.Range("A5").Value
        .Cells(1, 2).Resize(1, UBound(arr, 2)).Value = arr
    End With
    
End Sub

Private Function myTranspose(rr As Range) As Variant
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr, 1))
    
    Dim ya As Long
    Dim xa As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            brr(xa, ya) = arr(ya, xa)
        Next
    Next
    myTranspose = brr
End Function

Private Function GetSheet(sheetName As String) As Worksheet
    Dim sh As Worksheet
    Dim index_wb As Long
    
    On Error Resume Next
    For index_wb = Workbooks.Count To 1 Step -1
        Set sh = Workbooks(index_wb).Worksheets(sheetName)
        If Not sh Is Nothing Then
            Set GetSheet = sh
            Exit For
        End If
    Next
    
    On Error GoTo 0
End Function
 
Перейти    
Подстановка значения в зависимости от заданного диапазона дат, Как обеспечить "подтягивание" в нужный столбец данных, соответствующих определенному временному диапазону
 
#
21.05.2024 14:39:15
Код
=ЕСЛИ(A2<=ИНДЕКС($F$1:$F$6;ПОИСКПОЗ(A2;E:E;1));ИНДЕКС($D$1:$D$6;ПОИСКПОЗ(A2;E:E;1));"")
Во втором приближении.
 
Перейти    
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 224 След.
Наверх