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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 160 След.
Как создать диалоговое окно для выбора страницы книги, при копировании данных макросом
 
Код
Sub ЯтолькоСпросить()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Visible = xlSheetVisible Then
            sh.Select
            Select Case MsgBox("Надо ли перенести данные с " & sh.Name, vbQuestion + vbYesNoCancel)
            Case vbYes
                'ПЕРЕНОС
            Case vbCancel
                Exit For
            End Select
        End If
    Next
End Sub
Открыть csv в UTF-8 и сохранение в UTF-8
 
Ещё бы на сайте OpenOffice появилась ссылка на сайт Андрея Нечитаева ))
Автоматические выделения последнего повторяющегося значения и уникального (не повторяющегося значения)
 
В формулу условного форматирования
Код
=СЧЁТЕСЛИМН(C1:C$1048576;C1)=1
Копирование файла из сообщения Outlook в папку, открытую по гиперссылке
 
Код
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("G5:V500")) Is Nothing Then  ' Открывает нужную папку  гиперссылкой
            ActiveCell.EntireRow.Cells(5).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
            Application.Wait Now + TimeSerial(0, 0, 2) 'Задержка срабатывания макроса
            Target = Date
            Dim Outlook As Object
            Set Outlook = GetObject(, "Outlook.Application")
            Outlook.ActiveExplorer.Activate 'Активирует Аутлук
            Dim oMail As Object
            Set oMail = Outlook.ActiveExplorer.Selection.Item(1)
            Dim oAtch As Object
            For Each oAtch In oMail.Attachments
                oAtch.SaveAsFile ActiveCell.EntireRow.Cells(5).Hyperlinks(1).Address & "\" & oAtch
            Next
            
            Application.EnableEvents = True
            Cancel = True
    End If
End Sub
Изменено: МатросНаЗебре - 27.09.2022 17:12:29
расчет сумм с разными значениями
 
Вот ещё хороший вариант.
Поиск ближайшего числа (planetaexcel.ru)
Способ 2. ВПР с интервальным просмотром
Открыть csv в UTF-8 и сохранение в UTF-8
 
Изменение кодировки текста и файлов | Макросы Excel (excelvba.ru)
Печать нескольких листов в PDF, Как сохранить несколько листов, в которых настроена область печати, в пдф
 
Файл - Сохранить как - Тип файла: PDF - Параметры - Выделенные листы
перенос строк в создаваемом письме Outlook, Перенос текстовых строк при создании письма Outlook
 
Код
.HTMLBody = "Расчетная таблица за Август<BR>новый строки"
Заливка ячеек сроки цветом после полного заполнения диапазона той же строки данными
 
Код
Sub ЗакраситьАктивныйЛист()
    Dim rr As Range
    For Each rr In ActiveSheet.UsedRange.Rows
        CheckRow rr
    Next
End Sub

Sub CheckRow(rRows As Range)
    With rRows
        Dim arr As Variant
        arr = .Cells(1, [G1].Column).Resize(1, [V1].Column - [G1].Column + 1)
        Dim xx As Long
        Dim flagEmpty As Boolean
        For xx = 1 To UBound(arr, 2)
            If IsEmpty(arr(1, xx)) Then
                flagEmpty = True
                Exit For
            End If
        Next
        If Not flagEmpty Then
            Union(.Range("B1"), .Range("C1"), .Range("D1")).Interior.Color = RGB(200, 255, 200)
        End If
    End With
End Sub
Подсветка дат в ячейках с помощью условного форматирования и элементов управления форм, Необходимо подсветить сроки по нескольким условиям для нескольких параметров с возможностью включения/выключения
 
Измените формулы в условном форматировании:
Код
УДАЛИТЬ        =$A$6<>ИСТИНА
=($A$6)*И($J11>$C$9;$J11<=СЕГОДНЯ()+30)
=($A$6)*($J11>СЕГОДНЯ()+30)
=($A$6)*($J11<$C$9)
УДАЛИТЬ        =$A$7<>ИСТИНА
=($A$7)*($E11<$C$9)
Как разархивировать архив RAR через VBA
 
Вместо
Код
DowloadFolder = "C:\Users\Менеджер\Documents\"
Лучше использовать
Код
DowloadFolder = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\"
РАНГ по разным категориям из одного списка, Проставить ранг основываясь на данных по времени с учетом категории участника
 
Если есть возможность отсортировать по Категории, то такой вариант:
Код
=РАНГ([@Время];СМЕЩ(Таблица1[[#Заголовки];[Время]];ПОИСКПОЗ([@Категория];[Категория];0);0;СЧЁТЕСЛИМН([Категория];[@Категория]));1)
задача по экономике
 
Такой вариант.
При производительности 900 шт/ч 62000шт производили за 62000/900=69 часов.
При производительности 1200 шт/ч будут производить за 62000/1200=52 часа.
Закупка новой формы сэкономит 17 часов.

1 час стоит:
Если работают в одну смену по 8 часов, то 1500000/21/8 = 8929 руб.
Если работают круглосуточно 24*7, то 1500000/21/8 = 2083 руб.

Итого,
если производство работает 8 часов по будням,
то форма окупится за 72000/(17*8929) = 0,45 месяца = 2 недели.

если производство работает круглосуточно, то форма окупится за
72000/(17*2083) = 2 месяца.
Вставить значения в определенный диапазон при условии, Вставить значения в определенный диапазон при условии
 
Код
Sub MyCopy()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets("Лист1")
    Set sh2 = Sheets("Лист2")
    
    Dim dt As Date
    dt = sh1.Range("A1").Value
    Dim mm As Long
    mm = Month(dt) + 12 * (Year(dt) - 2022) - 9
    
    Dim arr As Variant
    arr = sh1.Cells(11 + 10 * mm, 1).Resize(10, 5)
    
    sh2.Cells(1 + 10 * mm, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
Изменено: МатросНаЗебре - 22.09.2022 17:25:48
Снятие фильтра с таблицы перед установкой нового фильтра., Оригинальная тема : Снятие фильтра с таблицы посредством MsgBox,
 
Код
If MsgBox("Выключить фильтр?", vbQuestion + vbYesNo, "Фильтр") = vbYes Then ActiveSheet.UsedRange.AutoFilter
Макрос для нарезки файла по условию
 
Цитата
написал:
не думал, что код получится таким длинным
Как ни парадоксально звучит, но иногда для упрощения понимания кода, его нужно удлинять )
Замена запятых на точки в большом количестве txt файлов
 
Код
Sub ReplaceComma()
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim sBuff As String
    sBuff = ThisWorkbook.FullName & ".txt"
    
    Dim vFile As Variant
    For Each vFile In aFiles
        ReplaceCommaInFile vFile, fso, sBuff
    Next
End Sub

Private Sub ReplaceCommaInFile(ByVal sFile As String, fso As Object, sBuff As String)
    
    Dim ss As String
    Dim ts As Object
    Set ts = aaa.OpenTextFile(sFile, 1)
    Dim tb As Object
    Set tb = fso.CreateTextFile(sBuff, True)
    With ts
        Do
            If .Atendofstream Then Exit Do
            ss = .Read(100000)
            ss = Replace(ss, ",", ".")
            tb.Write ss
        Loop
        .Close
    End With
    tb.Close
    Kill sFile
    Name sBuff As sFile
End Sub

Private Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        '.Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        .Filters.Add "Text files", "*.txt", 1 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\"
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
           arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
        Next
        ShowFileDialog = arr
    End With
End Function

Изменено: МатросНаЗебре - 21.09.2022 16:54:12 (Для больших файлов.)
Замена запятых на точки в большом количестве txt файлов
 
Код
Sub ReplaceComma()
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim vFile As Variant
    For Each vFile In aFiles
        ReplaceCommaInFile vFile, fso
    Next
End Sub

Private Sub ReplaceCommaInFile(ByVal sFile As String, fso As Object)
    Dim ss As String
    With fso.OpenTextFile(sFile, 1)
        If Not .Atendofstream Then ss = .ReadAll
        .Close
    End With
    ss = Replace(ss, ",", ".")
    With fso.CreateTextFile(sFile, True)
        .Write ss
        .Close
    End With
End Sub

Private Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        '.Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        .Filters.Add "Text files", "*.txt", 1 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\"
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
           arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
        Next
        ShowFileDialog = arr
    End With
End Function

Макрос для нарезки файла по условию
 
Код
Sub SplitFile()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim wb As Workbook
    Dim sh As Worksheet
    Set wb = ActiveWorkbook
    Set sh = wb.Sheets("Источник")
    
    Dim dic As Object
    Set dic = GetDic(sh)
    If dic Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim vfo As Variant
    For Each vfo In dic.Keys
        JobFO vfo, wb, sh, fso
    Next
    
    Application.Calculation = Application_Calculation
    Application.EnableEvents = True
End Sub

Private Sub JobFO(ByVal sfo As String, wb As Workbook, sh As Worksheet, fso As Object)
    Application.StatusBar = sfo
    Dim sName As String
    Dim sFull As String
    sName = sfo & "." & fso.GetExtensionName(wb.Name)
    sFull = wb.Path & "\" & sName
    On Error Resume Next
    Workbooks(sName).Close False
    Kill sFull
    On Error GoTo 0
    
    wb.SaveCopyAs sFull
    
    Dim wbTarget As Workbook
    Set wbTarget = Workbooks.Open(sFull)
    
    JobSheet wbTarget.Sheets(sh.Name), sfo
    
    wbTarget.RefreshAll
    wbTarget.Close True
    Application.StatusBar = False
End Sub

Private Sub JobSheet(sh As Worksheet, sfo As String)
    With sh
        Dim yy As Long
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim arr As Variant
        Dim brr As Variant
        With .Cells(2, 1).Resize(yy - 1, 4)
            arr = .Cells
            ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
            Dim uu As Long
            Dim xx As Long
            For yy = 1 To UBound(arr, 1)
                If arr(yy, 1) = sfo Then
                    uu = uu + 1
                    For xx = 1 To UBound(arr, 2)
                        brr(uu, xx) = arr(yy, xx)
                    Next
                End If
            Next
            
            .Cells = brr
        End With
    End With
End Sub

Private Function GetDic(sh As Worksheet) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With sh
        Dim yy As Long
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        If yy = 1 Then Exit Function
        Dim arr As Variant
        arr = .Cells(1, 1).Resize(yy)
    End With
    For yy = 2 To UBound(arr, 1)
        If IsEmpty(arr(yy, 1)) Then
        Else
            If Not dic.Exists(arr(yy, 1)) Then dic.Add arr(yy, 1), Empty
        End If
    Next
    Set GetDic = dic
End Function
Окрашивание ячейки по значению., Сравнительный анализ ячеек за аналогичный период.
 
Цитата
написал:
формула при копировании ячеек по колонке вниз не переносится
Не нужно писать условное форматирование отдельно для каждой ячейки. Удалите всё условное форматирование, и создайте для диапазонов форматирование, заданное формулами, как в сообщении #2.
Окрашивание ячейки по значению., Сравнительный анализ ячеек за аналогичный период.
 
Цитата
написал:
значения больше аналогичного за прошедший периода (больше чем в ячейки G44), ячейка G61 окрашивается в красный цвет
В формулу условного форматирования
Код
=И(НЕ(ЕПУСТО(G61));G61>G44)


Обучение условному форматированию в Excel с примерами (exceltable.com)
Изменено: МатросНаЗебре - 21.09.2022 11:00:48
Обращение к книге с переменным названием для копирования данных
 
Код
    For Each wb In Application.Workbooks
        If wb.Name Like "*port" & i & "angle" & j & "AZ*.txt " Then wb.Sheets(1).Range("A1:AQ1340").Copy
    Next
Макрос на копирование файлов с переименованием, Необходимо создать 2 макроса на копирование файлов с переименованием + 1 макрос на копирование выбранного артикула в соседнюю табличку
 
Пишу в личку.
Сделал.
Оплату получил.
Изменено: МатросНаЗебре - 20.09.2022 13:44:13
[ Закрыто] Работа со списками
 
Цитата
написал:
1.  при выборе какого либо месяца на листе отображалось то количество дней, сколько их в этом месяце
2. тоже самое касается при выборе года, при високосном в феврале 29 дней
Код
=ДЕНЬ(КОНМЕСЯЦА(ДАТАЗНАЧ(1&Y3&AG3);0))
Первые два вопроса сводятся к одному. А вот третий от них сильно отличается. Здесь принято, один вопрос - одна тема. Желательно создать другую тему.
VBA Открыть другой файл, excel
 
Код
Set wb = Workbooks.Open(ПУТЬ & ИМЯ_ФАЙЛА )
Application.Run "'" & ИМЯ_ФАЙЛА & "'!" & ИМЯ_МАКРОСА
Требуется помощь в составлении формулы
 
Цитата
написал:
Еще пара вариантовКод ? 1=СЧЁТЕСЛИМН
В палеолите не знают про СЧЁТЕСЛИМН )
Пример в xls.
Изменено: МатросНаЗебре - 14.09.2022 17:20:46
Макрос для группировки строк по кол-ву точек в первой строке
 
Код
Sub myGroup()

    ActiveSheet.Cells.ClearOutline
    ActiveSheet.Outline.SummaryRow = xlAbove
    
    Dim n1 As Long
    Dim n2 As Long
    Dim y1 As Long
    Dim y2 As Long
    For y1 = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        n1 = GetNdot(Cells(y1, 1))
        For y2 = y1 + 1 To Cells(Rows.Count, 1).End(xlUp).Row
            n2 = GetNdot(Cells(y2, 1))
            If n2 <= n1 Then Exit For
        Next
        y2 = y2 - 1
        Range(Cells(y1, 1), Cells(y2, 1)).EntireRow.Group
    Next
End Sub

Private Function GetNdot(txt As String) As Long
    GetNdot = Len(txt) - Len(Replace(txt, ".", ""))
End Function
Требуется помощь в составлении формулы
 
Код
=(СЧЁТЕСЛИ(F9:T10;7)+СЧЁТЕСЛИ(V9:AK10;7))*5+(СЧЁТЕСЛИ(F9:T10;4)+СЧЁТЕСЛИ(V9:AK10;4))*2
Вариант названия темы
Как исключить значение из СЧЁТЕСЛИ.
2 формулы в ячейку или время без двоеточия, Необходимо убрать :
 
Цитата
написал:
Мне надо минуты, секунды.
Код
=ТЕКСТ(ВРЕМЗНАЧ("00:"&ЕСЛИ(ДЛСТР(A1)>2;ЛЕВСИМВ(A1;ДЛСТР(A1)-2);"00")&":"&ПРАВСИМВ(A1;2))+ВРЕМЗНАЧ("00:"&ЕСЛИ(ДЛСТР(B1)>2;ЛЕВСИМВ(B1;ДЛСТР(B1)-2);"00")&":"&ПРАВСИМВ(B1;2));"чч:мм")&"  "

Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Column > 2 Then Exit Sub
    If Len(Target.Value) < 2 Then Exit Sub
     
    Dim hh As String
    Dim mm As String
    mm = Right(Target.Value, 2)
    If Len(Target.Value) > 2 Then
        hh = Left(Target.Value, Len(Target.Value) - 2)
    Else
        hh = "00"
    End If
    Application.EnableEvents = False
    Target.NumberFormat = "h:mm"
    Target.Value = TimeSerial(0, hh, mm)
    Application.EnableEvents = True
End Sub
Изменено: МатросНаЗебре - 14.09.2022 15:52:27
На каждом листе проставить дату взятую из названия листа
 
Код
Sub FillDate()
    Dim dt As Date
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        dt = 0
        On Error Resume Next
        dt = DateValue(sh.Name)
        On Error GoTo 0
        If dt > 0 Then sh.Range("G4").Value = dt
    Next
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 160 След.
Наверх