Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 234 След.
Извлечь две даты, записанные через тире
 
Для ячеек типа 25.09 - 04.10 год вставляете в функцию, n=0 для первой даты, n=1 для второй даты
UDF
Код
Function GetDate(cell As Range, iYear As Integer, n As Integer) As Date
Dim arr
  arr = Split(cell, "-")
  GetDate = CDate(Application.Trim(arr(n)) & "." & iYear)
End Function

Вызов =GetDate(D2;2019;0) и =GetDate(D2;2019;1)
Изменено: Kuzmich - 8 Апр 2020 11:55:24
Заполнение данных сводной таблицы с использование VBA, Заполнение данных сводной таблицы из листа с вручную введенными данными использование поиска VBA
 
Код
Cells(26, "B") = .Cells(FoundCell.Row, "C")
Cells(26, "E") = .Cells(FoundCell.Row, "C")
Cells(26, "W") = .Cells(FoundCell.Row, "C")
Cells(26, "AG") = .Cells(FoundCell.Row, "C")

Почему из одной ячейки в четыре разные?
Заполнение данных сводной таблицы с использование VBA, Заполнение данных сводной таблицы из листа с вручную введенными данными использование поиска VBA
 
На листе DATA_REPORT ячейка C#, только вы точку забыли
Код
.Cells(FoundCell.Row, "C")
Заполнение данных сводной таблицы с использование VBA, Заполнение данных сводной таблицы из листа с вручную введенными данными использование поиска VBA
 
Цитата
а то немного не пойму как правильно...
А чем это отличается от
Цитата
например из ячейки AB1 листа ADD_DATA_REPORT в ячейку B#, где # номер строки ранее найденного значения
Заполнение данных сводной таблицы с использование VBA, Заполнение данных сводной таблицы из листа с вручную введенными данными использование поиска VBA
 
При активном листе ADD_DATA_REPORT
Код
Sub ReportNomer()
Dim FoundCell As Range
  With Worksheets("DATA_REPORT")
    Set FoundCell = .Columns(1).Find(Range("V1"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       .Cells(FoundCell.Row, "B") = Range("AB1")
       Cells(26, "B") = .Cells(FoundCell.Row, "C")
     Else
       MsgBox "НЕ НАЙДЕНО ЗНАЧЕНИЕ"
     End If
  End With
End Sub
Копирование диапазона без выделения листа
 
Цитата
макрос понимал динамический диапазон, начиная с ячейки J9
Код
Sub мкр3()
  With Worksheets("Лист2")
    Range("J9:J" & Cells(Rows.Count, "J").End(xlUp).Row).Copy .Cells(1, 1)
  End With
End Sub
При печати путевого листа менять дату
 
Цитата
кто поможет кину 50 на телефон или карту
Кто-то губу раскатал,
а ТС даже спасибо не сказал.
Утром был на сайте, очередной трутень!
Макрос на копирование ячеек из других файлов, Макрос на копирование ячеек из других файлов
 
Цитата
Нужно ОЧЕНЬ срочно, за помощь донат

Поиск вам в помощь, например
https://www.excel-vba.ru/forum/index.php?board=3.0
При печати путевого листа менять дату
 
Цитата
как макрос запустить ...
Зайдите в приемы
https://www.planetaexcel.ru/techniques/3/59/
При печати путевого листа менять дату
 
nazr,
Перед печатью запускаете макрос, который прибавляет один день
Код
Sub iDate()
Dim iDate As Date
Dim iDay As Integer
Dim iMonth As Integer
Dim iYear As Integer
  iDate = CDate(Range("I5") & " " & Range("K5") & " " & Range("O5")) + 1
    Range("I5") = Day(iDate)
  iMonth = Month(iDate)
  Range("K5") = Application.Index(Array("января", "февраля", "марта", "апреля", "мая", "июня", _
                "июля", "августа", "сентября", "октября", "ноября", "декабря"), iMonth)
    Range("O5") = Year(iDate)
End Sub
Изменено: Kuzmich - 6 Апр 2020 22:11:23 (упростил код)
Найти сумму объема потребленного ресурса за каждый месяц по каждому дому
 
Цитата
В приложении указал формат данных который мне необходимо получить
Как у вас связаны два листа? Где нужный формат?
Как в ячейке поменять местами 3 слова
 
UDF
Код
Function iFio(iCell As Range) As String
Dim re
Set re = CreateObject("VBScript.RegExp")
     re.Global = True
     re.ignorecase = True
re.Pattern = "([А-ЯЁ]+) ([А-ЯЁ]+) ([А-ЯЁ]+)"
    iFio = re.Replace(iCell, "$3 $2 $1")
End Function
Количество работников, получивших зарплату
 
Макросом
Код
Sub Zarplata()
Dim dicObj As Object
Dim i&
  Range("E2:F" & Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
Set dicObj = CreateObject("scripting.dictionary")
  For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    dicObj.Item(CStr(Cells(i, "A"))) = dicObj.Item(CStr(Cells(i, "A"))) + Cells(i, "B")
  Next i
   Range("E2").Resize(dicObj.Count, 2) = Application.Transpose(Array(dicObj.Keys, dicObj.Items))
  For i = Cells(Rows.Count, "E").End(xlUp).Row To 2 Step -1
    If Cells(i, "F") = 0 Then Range("E" & i & ":F" & i).Delete shift:=xlUp
  Next
  Range("F1") = WorksheetFunction.CountA(Range("E2:E" & Cells(Rows.Count, "E").End(xlUp).Row))
End Sub
Автозаполнение нумерации до конца смежного столбца
 
Цитата
только глава не всегда 2, а постоянно меняется но +1 от предыдущей
Код
Sub Tablica()
Dim iLastRowB As Long
Dim iLastRowC As Long
Dim n As Long
Dim Glava As String
 iLastRowB = Cells(Rows.Count, "B").End(xlUp).Row
 iLastRowC = Cells(Rows.Count, "C").End(xlUp).Row
   Glava = Left(Cells(iLastRowB, "A"), 5) & Mid(Cells(iLastRowB, "A"), 6) + 1
   n = 1
 Do
   Cells(iLastRowB + n, "A") = Glava
   Cells(iLastRowB + n, "B") = "n" & n
    n = n + 1
 Loop While n < iLastRowC - iLastRowB + 1
End Sub
как сложить только цифры если в ячейке есть ещё и текст
 
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iSumma As Double
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  For i = 3 To iLastRow
    If Not IsEmpty(Cells(i, "D")) Then
     iSumma = iSumma + CDbl(Split(Cells(i, "D"), "=")(1))
    End If
  Next
    Cells(iLastRow + 1, "D") = iSumma
    Cells(iLastRow + 1, "D").NumberFormat = "#,##0.00"
    Cells(iLastRow + 1, "D").Font.Bold = True
End Sub
Автозаполнение нумерации до конца смежного столбца
 
Код
Sub Tablica()
Dim iLastRowB As Long
Dim iLastRowC As Long
Dim n As Long
 iLastRowB = Cells(Rows.Count, "B").End(xlUp).Row
 iLastRowC = Cells(Rows.Count, "C").End(xlUp).Row
   n = 1
 Do
   Cells(iLastRowB + n, "A") = "Глава2"
   Cells(iLastRowB + n, "B") = "n" & n
    n = n + 1
 Loop While n < iLastRowC - iLastRowB + 1
End Sub
VBA. ВПР данных с разных листов
 
Цитата
хочется, чтобы при запуске макроса в файле1
При условии, что оба файла открыты и в файле2 ("Файл2.xls") точно есть листы с номерами недели,
макрос в стандартный модуль файла1
Код
Sub SborFromFile2()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim FoundCell As Range
Dim File2 As Workbook
Dim iFile2ShtName As String
  Set File2 = Workbooks("Файл2.xls")
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("B3:D" & iLastRow).ClearContents
  For i = 3 To iLastRow
    For j = 2 To 4
      iFile2ShtName = Cells(2, j) & "_нед"
      With File2.Worksheets(iFile2ShtName)
       Set FoundCell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
       If Not FoundCell Is Nothing Then
         Cells(i, j) = .Cells(FoundCell.Row, 2)
       End If
      End With
    Next
  Next
End Sub
Статус бар с количеством заполненных и пустых ячеек
 
Цитата
Хочу вставить сюда стандартный статус бар (который отображает результат в левом нижнем углу окна),
Может вам это нужно
http://www.excel-vba.ru/chto-umeet-excel/otobrazit-process-vypolneniya/
Расчёт промежуточных итогов, при определённых условиях, расчёт промежуточных итогов за прошлый день, в автоматическом формате
 
hex01011100,
Макрос срабатывает на изменение ячейки в столбце А
это ваша очередная дата
Как подсчитать количество символов в ячейке до определенного символа?
 
Код
Function iText(cell$)
 With CreateObject("VBScript.RegExp")
  .Pattern = "A-Class : .+(?=FI :)"
  iText = Mid(.Execute(cell)(0), 10)
 End With
End Function
Расчёт промежуточных итогов, при определённых условиях, расчёт промежуточных итогов за прошлый день, в автоматическом формате
 
При условии, что между блоками две пустые строки,
макрос в модуль листа Лист1
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Columns("A")) Is Nothing Then
   Application.EnableEvents = False
Dim iRow As Long
      iRow = Target.Row
    Do
      iRow = iRow - 1
    Loop While Cells(iRow, "A") = ""
      Cells(Target.Row - 1, "G") = WorksheetFunction.Sum(Range(Cells(iRow, "F"), Cells(Target.Row - 2, "F")))
 End If
   Application.EnableEvents = True
End Sub
Как подсчитать количество символов в ячейке до определенного символа?
 
Цитата
то с первым я просто не знаю, что делать.
Изучать регулярные выражения.
Расчёт промежуточных итогов, при определённых условиях, расчёт промежуточных итогов за прошлый день, в автоматическом формате
 
А почему фотобарабан не посчитали?
И зачем дату задавать так =ДАТА(2020;4;2)?
Изменено: Kuzmich - 2 Апр 2020 18:11:58
Сравнить строки по значениям в столбцах и выделить одинаковые
 
Цитата
Правда есть ошибка
Подробнее опишите, в чем она выражается?
"уникальный kod" определяется как уникальные значения из столбца L
"уникальный kod1" определяется как уникальные значения из столбца O
Удачи!
Перенести из Пларования в Производство значения и заливку
 
Цитата
но красить их приходится вручную, а хочется чтобы ячейки красились автоматически тем же цветом
Код
'запускать при активном листе 'планирование'
Sub Perenos()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 With Worksheets("производство")
   .Range("C3:I8").ClearContents
   .Range("C3:I8").Interior.ColorIndex = xlNone
  For i = 2 To iLastRow
    Set FoundCell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
        Range("B" & i & ":H" & i).Copy
        .Cells(FoundCell.Row, "C").PasteSpecial xlPasteAll
     End If
  Next
 End With
   Application.CutCopyMode = False
End Sub
Сравнить строки по значениям в столбцах и выделить одинаковые
 
Цитата
но не определяет совпадение по пропорциям входящих в состав компонентов.
Добавил эту функцию в макрос. Посмотрите и потестируйте. Удачи!
Сравнить строки по значениям в столбцах и выделить одинаковые
 
И мой вариант посмотрите
Код
Sub Komponent()
Dim i As Long
Dim iLastRow As Long
Dim iLastCol As Integer
Dim j As Integer
Dim FoundKod As Range
Dim FirstRow As Long
Dim SecondRow As Long
Dim FAdr As String
Application.ScreenUpdating = False
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 iLastCol = Cells(2, Columns.Count).End(xlToLeft).Column
 Range("L2:M" & iLastRow).ClearContents
 Range("L2:L" & iLastRow).NumberFormat = "@"
  For i = 3 To iLastRow             'формируем код
    For j = 2 To iLastCol
      If Not IsEmpty(Cells(i, j)) Then
        Cells(i, "L") = Cells(i, "L") & "1"
      Else
        Cells(i, "L") = Cells(i, "L") & "0"
      End If
    Next
  Next
  For i = 3 To iLastRow
        Set FoundKod = Range("L" & i - 1 & ":L" & iLastRow).Find(Cells(i, "L"), , xlValues, xlWhole)
       FAdr = FoundKod.Address
       FirstRow = FoundKod.Row
      Do
        Set FoundKod = Range("L" & i - 1 & ":L" & iLastRow).FindNext(FoundKod)
        If FoundKod.Address <> FAdr And Not IsEmpty(Cells(FoundKod.Row, "L")) Then
           SecondRow = FoundKod.Row
           Cells(FirstRow, "M") = "Есть совпадение: " & Cells(FirstRow, "A") & " - " & Cells(SecondRow, "A")
           Cells(SecondRow, "M") = "Есть совпадение: " & Cells(SecondRow, "A") & " - " & Cells(FirstRow, "A")
        End If
      Loop While FoundKod.Address <> FAdr
  Next
Application.ScreenUpdating = True
End Sub
Синтаксис Range при обращении с столбцам "умной таблицы"
 
Цитата
Не могу найти синтаксис при обращении к умным таблицам
Изучайте
https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables
Сумма не повторяющихся сотрудников со статусами (в зависимости от фильтра)
 
Цитата
посчитать количество не повторяющихся ФИО со статусом
Код
Sub Kol_vo()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
   Columns("F").Delete
  For i = iLastRow To 7 Step -1
    If Cells(i, "D") = "" Or Cells(i, "D") = "МВ" Then
      Rows(i).Delete
    End If
  Next
 iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
 Range("C6:C" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("F6"), Unique:=True
 iLastRow = Cells(Rows.Count, "F").End(xlUp).Row
 Range("D2") = WorksheetFunction.CountA(Range("F7:F" & iLastRow))
  Columns("F").Delete
End Sub
Сохранение визуального отображения формата как значения
 
Sharmat,
о вашей теме Количество строк в группировке
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 234 След.
Наверх