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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 249 След.
Вставить данные с любой из ячеек в одну определённую
 
В общем-то, удачи  
Не бойтесь совершенства. Вам его не достичь.
Макрос для удаления строк, если в столбцах есть конкретный текст
 
karlson7, тогда так
Код
Sub nakl_B()
Dim cell As Range, i As Long, lr As Long, arr, arr2, n As Long, x As Long
arr = Array(2, 4, 18)
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
For n = LBound(arr) To UBound(arr)
x = InStr(1, Cells(i, arr(n)), "накле", 1)
If x > 0 Then
    If cell Is Nothing Then
        Set cell = Cells(i, 1): Exit For
    Else
        Set cell = Union(cell, Cells(i, 1)): Exit For
    End If
End If
Next n
Next i
    If Not cell Is Nothing Then cell.EntireRow.Delete
End Sub

Не бойтесь совершенства. Вам его не достичь.
Макрос для удаления строк, если в столбцах есть конкретный текст
 
karlson7, в этом файле предложенный мной макрос не отрабатывает указанные Вами ячейки?
Не бойтесь совершенства. Вам его не достичь.
Макрос для удаления строк, если в столбцах есть конкретный текст
 
Покажите то что не удаляется в файле
Не бойтесь совершенства. Вам его не достичь.
Макрос для удаления строк, если в столбцах есть конкретный текст
 
karlson7, так?
Код
Sub nakl_B()
Dim cell As Range, i As Long, lr As Long, arr, n As Long
arr = Array(2, 4, 18)
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
For n = LBound(arr) To UBound(arr)
If Cells(i, arr(n)) Like "*накле*" Then
    If cell Is Nothing Then
        Set cell = Cells(i, 1): Exit For
    Else
        Set cell = Union(cell, Cells(i, 1)): Exit For
    End If
End If
Next n
Next i
    If Not cell Is Nothing Then cell.EntireRow.Delete
End Sub
Не бойтесь совершенства. Вам его не достичь.
Замена ячеек
 
nicex, что-то ничего не понятно вообще...покажите в файле отдельно исходные и рядом ожидаемый результат
Не бойтесь совершенства. Вам его не достичь.
Вставить данные с любой из ячеек в одну определённую
 
Ruskat, не понял немного, в модуль листа с данными, работает при двойном нажатии
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("E2:E18")) Is Nothing Then
Dim arr, i As Long, tt As String
arr = Split(Target, Chr(10))
For i = LBound(arr) To UBound(arr)
    If tt = "" Then
        tt = Left(arr(i), InStr(arr(i), "(") - 1)
        
    Else
        tt = tt & vbCrLf & Left(arr(i), InStr(arr(i), "(") - 1)
    End If
Next i
Range("F1") = tt
Cancel = True
End If
End Sub
Не бойтесь совершенства. Вам его не достичь.
Скопировать содержимое ячейки, убрать определенную часть и записать в другую ячеку макросом
 
Santiago, для конкретного примера
Код
=ПСТР(A2;1;НАЙТИ(СИМВОЛ(1);ПОДСТАВИТЬ(A2;"-";СИМВОЛ(1);3))-1)
Не бойтесь совершенства. Вам его не достичь.
Вывод из одной таблицы информации по районам на отдельные листы
 
Horbon Иван, ясно) удачи)
Не бойтесь совершенства. Вам его не достичь.
Скопировать содержимое ячейки, убрать определенную часть и записать в другую ячеку макросом
 
Santiago, 105 сообщений, а про файл пример с исходными данным и показанным желаемым результатом забыли..
Не бойтесь совершенства. Вам его не достичь.
Вывод из одной таблицы информации по районам на отдельные листы
 
Horbon Иван,ЛОГИКА КАКАЯ? или просто конкретные с конкретными?
Не бойтесь совершенства. Вам его не достичь.
Возвращение списка значений по шифру
 
wammaxy, а вам удобна такая структура?
а так тут ваше решение https://www.planetaexcel.ru/techniques/2/81/
Изменено: Mershik - 14.06.2021 19:41:24
Не бойтесь совершенства. Вам его не достичь.
Вывод из одной таблицы информации по районам на отдельные листы
 
Horbon Иван, покажите в файле желаемый результат для пары таких объединений, потому что логику пока я не пойму
Изменено: Mershik - 14.06.2021 19:38:14
Не бойтесь совершенства. Вам его не достичь.
Перенести даты из столбца в строку напротив ФИО работника
 
Цитата
Kubix написал:
вытягивает данные со всех работников
не не правда - с последнего не вытягивает так как он не группирован.
Не бойтесь совершенства. Вам его не достичь.
Перенести даты из столбца в строку напротив ФИО работника
 
Kubix, ориентировался на группировку 3-4 если ее нет результата не бдует.
Код
Sub Макрос1()
Dim i As Long, lr As Long, x As Long, x2 As Long, n As Long, k As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
x = Rows(i).OutlineLevel
If x = 3 Then
k = 2
    For n = i + 1 To lr
    x2 = Rows(n).OutlineLevel
    If x2 = 4 Then
        Cells(i, k) = Cells(n, 1)
        k = k + 1
    Else
        i = n - 1
        Exit For
    End If
    Next n
End If
Next i
End Sub

Изменено: Mershik - 14.06.2021 12:36:37
Не бойтесь совершенства. Вам его не достичь.
Как в коде VBA записать название диапазона, в котором неизвестен адрес строки
 
Наталья Шалаева, объясните задачу просто словам без ваших знаний формул и макросов, просто что есть вот это, а хочу получить вот это (покажите желаемый результат рядом или на другом листе)  быстрее получите помощь
Не бойтесь совершенства. Вам его не достичь.
Как связать ФИО с номером карты
 
мила м, вопрос к Вам где файл-пример с исходными  данными и показанным желаемым результатом
Цитата
Я буду вводить фио (копировать) и ячейка с номером карты сама заполнится?
или может другой какой то выход есть?
можно создав список соответствий  
Изменено: Mershik - 12.06.2021 20:32:48
Не бойтесь совершенства. Вам его не достичь.
Как связать два разных значения из двух таблиц, которые находятся на разных листах
 
Виктория, покажите что должно получится по Вашему - ручками заполните
Изменено: Mershik - 12.06.2021 20:26:34
Не бойтесь совершенства. Вам его не достичь.
Вывод из одной таблицы информации по районам на отдельные листы
 
Horbon Иван,  вот это поможет
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=141203&a...
Запускать с листа с основной таблицей и без установленного фильтра:
Код
Sub iCopy()
Application.ScreenUpdating = False
Dim wsh As Worksheet, tt As String, sh As Worksheet, col As New Collection, lr As Long, ShN As String
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
    On Error Resume Next
    col.Add sh.Cells(i, 1), CStr(sh.Cells(i, 1))
Next i
For i = 1 To col.Count
ShN = col(i)
sh.ShowAllData
sh.Range("A1:J" & lr).AutoFilter Field:=1, Criteria1:=col(i)
For Each wsh In Worksheets
    If wsh.Name = ShN Then k = k + 1: Exit For
Next wsh
    If k = 0 Then
        Sheets.Add.Name = ShN
        sh.Range("A1:J" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).Copy
        ActiveSheet.Cells(1, 1).PasteSpecial xlPasteColumnWidths
        ActiveSheet.Cells(1, 1).PasteSpecial xlPasteValues
    Else
        With Worksheets(ShN)
            .Cells.Clear
            sh.Range("A1:J" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).Copy
            .Cells(1, 1).PasteSpecial xlPasteColumnWidths
            .Cells(1, 1).PasteSpecial xlPasteValues
        End With
    End If
Next i
sh.ShowAllData
Application.ScreenUpdating = True
End Sub
Изменено: Mershik - 12.06.2021 11:09:49
Не бойтесь совершенства. Вам его не достичь.
Исключить взаимное влияние SelectionChange и Change
 
aravin1983, выделяете макрос нажимаете на панели кнопку <...>
Не бойтесь совершенства. Вам его не достичь.
Перенос таблицы по фильтру на новый лист с ведённым именем
 
Виктор Резнов, запускать макрос с активного листа с исходной таблицей
Код
Sub iCopy()
Dim Sht As Worksheet, tt As String, sh As Worksheet
Set sh = ActiveSheet
tt = Application.InputBox("задайте имя для нового листа", Type:=2)
For Each Sht In Worksheets
    If Sht.Name = tt Then k = k + 1: Exit For
Next Sht
If k = 0 Then
    Sheets.Add.Name = tt
    sh.Range("A1:D" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).Copy
    Worksheets(tt).Cells(1, 1).PasteSpecial xlPasteColumnWidths
    Worksheets(tt).Cells(1, 1).PasteSpecial xlPasteValues
Else
    x = MsgBox("Лист с заданными именем существует." & Chr(10) & "ОК - данные на существующем листе будут стерты и вставлены новые" & Chr(10) & "Отмена - макрос прервется", vbOKCancel)
    If x = vbOK Then
        Worksheets(tt).Cells.Clear
        sh.Range("A1:D" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).Copy
        Worksheets(tt).Cells(1, 1).PasteSpecial xlPasteColumnWidths
        Worksheets(tt).Cells(1, 1).PasteSpecial xlPasteValues
    Else
        Exit Sub
    End If
End If
End Sub

Изменено: Mershik - 10.06.2021 20:38:23
Не бойтесь совершенства. Вам его не достичь.
Макрос разбивки на 3 столбца по 25 строк
 
Geptan, это вообще не понял
Цитата
с пререходом на следующий лист. (Под листом имееться ввиду печатная версия документа)
Код
Sub mrshkei()
Dim arr, arr2, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A1:B" & lr + 1): k = 1
i = 2: w = 4
For n = 1 To Abs(Int((-UBound(arr) + 1) / 32))
    ReDim arr2(1 To 33, 1 To 2)
    arr2(1, 1) = arr(1, 1): arr2(1, 2) = arr(1, 2)
    For j = 2 To 33
        arr2(j, 1) = arr(i, 1)
        arr2(j, 2) = arr(i, 2)
        i = i + 1
        If i > UBound(arr) Then GoTo 123
    Next j
123
    Cells(1, w).Resize(UBound(arr2), 2) = arr2
    w = w + 3
Next n
End Sub
Изменено: Mershik - 10.06.2021 13:55:40
Не бойтесь совершенства. Вам его не достичь.
Три последних символа иным цветом
 
msi2102,  :D
Код
Sub df()
Application.ScreenUpdating = False
Dim cell As Range, lr As Long, rng As Range, S As Long, L As Long
lr = Cells(Rows.Count, 3).End(xlUp).Row + 1
Set rng = Range("C2:C" & lr)
rng.Font.ColorIndex = xlAutomatic
'rng.Font.TintAndShade = 0
For Each cell In rng
If Not IsEmpty(cell) Then
If Len(cell) >= 3 Then
    S = Len(cell) - 2: L = 3
Else
    S = 1: L = Len(cell)
End If
    With cell.Characters(Start:=S, Length:=L).Font
        .Name = "Calibri"
        .FontStyle = "обычный"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16776961
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
End If
Next cell
Application.ScreenUpdating = True
End Sub
Изменено: Mershik - 10.06.2021 13:56:22
Не бойтесь совершенства. Вам его не достичь.
Три последних символа иным цветом
 
Цитата
Иван Доброславин написал:
Можно ли поменять цвет 3 символам справа?
да
Не бойтесь совершенства. Вам его не достичь.
Выбрать из массива данные с нужными маркерами и отсортировать их по возрастанию
 
zelek26,без понятия)
Не бойтесь совершенства. Вам его не достичь.
Выбрать из массива данные с нужными маркерами и отсортировать их по возрастанию
 
Код
Sub mrshkei()
Dim arr, arr2, arr3, i As Long, lr As Long, lr2 As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Cells(Rows.Count, 11).End(xlUp).Row + 1
Range("K10:Q" & lr2).ClearContents
arr = Range("A10:H" & lr)
arr2 = Range("S2:S6")
ReDim arr3(1 To lr, 1 To 8): k = 1
For i = LBound(arr) To UBound(arr)
    If Left(arr(i, 5), 2) = arr2(1, 1) & "." Then
        If arr(i, 2) = arr2(2, 1) Then
            If arr(i, 6) = arr2(3, 1) Then
                arr3(k, 1) = arr(i, 5)
                arr3(k, 2) = arr(i, 2)
                arr3(k, 3) = arr(i, 6)
                arr3(k, 4) = arr(i, 3)
                arr3(k, 5) = arr(i, 7)
                arr3(k, 6) = arr(i, 8)
                k = k + 1
            End If
        End If
    End If
Next i
Range("K10").Resize(lr, 8) = arr3
    ActiveWorkbook.Worksheets("1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("1").Sort.SortFields.Add2 Key:=Range("K10").Resize(lr, 1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("1").Sort
        .SetRange Range("K9").Resize(lr + 1, 8)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Изменено: Mershik - 09.06.2021 23:00:55
Не бойтесь совершенства. Вам его не достичь.
Выпадающий список, который проставляет всю строку значений определенный образом
 
Максим Николаевич,  :D  покажите Ваш файл куда вы вставили.
Не бойтесь совершенства. Вам его не достичь.
Макрос разбивки на 3 столбца по 25 строк
 
Geptan, файл пример исходных данных и желаемый результат рядом строк 50 хватит с головой
Не бойтесь совершенства. Вам его не достичь.
Отобразить выделенные ячейки в строку
 
Цитата
элина Шовгенова написал:
ИНДЕКС и ПОИСКПОЗ,
Код
=ИНДЕКС($B$2:$H$12;СТОЛБЕЦ()-1;ПОИСКПОЗ(B$17;$B$1:$H$1;0))
Не бойтесь совершенства. Вам его не достичь.
Создание документа Word по шаблону из Excel
 
denka1982,  а так в инете забейте слияние word например
https://office-guru.ru/excel/functions-tekstovye/sliyanie-dannyx-ms-word-i-ms-excel.html

если не понятно - уточняйте подскажу:
вот порядок.
1. Создайте в екселе базу. База должны иметь шапку и все они должны иметь имя. Не должно быть пустых строк среди заполненных т.е. идет 1 строка после шапки все столбцы заполнены, потом 2-я в ней нет данных и 3 снова данные - такого не должно быть.
2. Заходим в шаблон - Рассылки - выбрать список получателей  - использовать список получателей (выбираете файл ексель который готовили в 1 пункте) - нажимаете ок.
3. Вставляем поля слияния: Выделяете поэтапно нужный текст в шаблоне - вставить поле слияния - выбираете нужный вам столбец (это имена шапки из ексель) и так для каждого поля.
4. Дальше найти и объединить - и выбираете нужное или печать документов сразу пойдут на печать или изменить отдельные документы -  в данном случае создаться еще word документ со всем письмами
Изменено: Mershik - 09.06.2021 16:35:29
Не бойтесь совершенства. Вам его не достичь.
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 249 След.
Наверх