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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 233 След.
Автозаполнение нумерации до конца смежного столбца
 
Цитата
только глава не всегда 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,
о вашей теме Количество строк в группировке
Вытащить из адреса отдельно улицу, № дома и номер квартиры.
 
IamDubstpper, написал
Цитата
но мне нужен макрос.
В приемах читайте про регулярные выражения
Удаление пустых ячеек с условием
 
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iLastCol As Integer
Dim j As Integer
Application.ScreenUpdating = False
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
  For i = 2 To iLastRow
    For j = iLastCol To 4 Step -3
      If WorksheetFunction.CountA(Range(Cells(i, j - 2), Cells(i, j))) <> 3 Then
        Range(Cells(i, j - 2), Cells(i, j)).Delete shift:=xlToLeft
      End If
    Next
  Next
Application.ScreenUpdating = True
End Sub
Извлечь фрагмент между третьей и четвертой запятой
 
Цитата
Извлечь фрагмент между третьей и четвертой запятой
Было уже между первой и второй.
Универсально UDF в стандартный модуль
Код
'извлечь n-ое слово из текста, вызов  =nWord(A1;",";4)
Function nWord(cell As String, delimiter As String, n As Integer) As String
  Dim arr
  If Len(cell) - Len(Replace(cell, delimiter, "")) >= n Then
    arr = Split(cell, delimiter)
        nWord = arr(n - 1)
  Else
    nWord = cell
  End If
End Function
Сохранение визуального отображения формата как значения
 
Sharmat,
Прежде чем создавать новую тему надо отвечать в предыдущих
Перенос части текста с определенного слова в другую ячейке
 
Код
Sub ИН()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("B4:B" & iLastRow).ClearContents
   With CreateObject("VBScript.RegExp")
     .ignorecase = True
     .Pattern = "\(?ИНВ?-? ?\d+"
    For i = 5 To iLastRow
      If .Test(Cells(i, 1)) Then
        Cells(i, 2) = Right(Cells(i, 1), Len(Cells(i, 1)) - .Execute(Cells(i, 1))(0).FirstIndex)
        Cells(i, 1) = Left(Cells(i, 1), .Execute(Cells(i, 1))(0).FirstIndex)
      End If
    Next
   End With
End Sub
VBA - поиск всех значений по заданному условию и обновление связанных данных, FindNext в цикле ошибка
 
Цитата
в части продолжения поиска через FindNext
Метод FindNext не работает, если перед этим был поиск Find для другого аргумента
Нужно произвести поиск
Код
Set pInvoice = .Rows(rFndShipNr.Row).Find(rInvoice, pInvoice)

И переменные определить как Range
Код
Dim rPayDate As Date, rPayWeek As Range, pInvoice As Range

И остальные переменные приведите в соответствие
Перемещение строки на другой лист по условию, Помогите прикрутить макрос по переносу строк в списке задач по статусу "завершено"
 
trainee, написал
Цитата
Расшифруйте пожалуйста синтаксис этой строчки,
Код
Range("B" & i & ":J" & i).Copy
   
Для i=4 это Range("B4:J4").Copy и этот диапазон копируется на лист Sheets("Завершенные")
Можно использовать конструкцию типа
Код
Range(Cells(i, "B"), Cells(i, "J")).Copy
Перемещение строки на другой лист по условию, Помогите прикрутить макрос по переносу строк в списке задач по статусу "завершено"
 
trainee,
Вы копируете диапазон
Код
Range("B" & CStr(i) & ":J" & i).Copy 

в
Код
Sheets("Завершенные").Range("B" & lr)

при этом переменную lr не изменяете и у вас все копируется в одну строку
После удаления строки
Код
Rows(i).Delete

добавьте
Код
lr=lr + 1
Перемещение строки на другой лист по условию, Помогите прикрутить макрос по переносу строк в списке задач по статусу "завершено"
 
trainee,
Что-то я сомневаюсь в правильной работе макроса.
Цикл надо делать от последней строки до 4 с шагом -1
Код
For i =  Cells(Rows.Count, 4).End(xlUp).Row To 4 Step -1
Копирование части таблицы основываясь на цвете заливки ячеек
 
Цитата
копирует все данные предыдущего дня изменяет дату заполнения
Макрос в стандартный модуль
Код
Sub iCopyDiapazon()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim FoundData As Range
  For Each Sht In Worksheets
    With Sht
      iLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
      'ищем ячейку с последней датой (слово Дата)в столбце А
      Set FoundData = .Columns(1).Find("Дата", .Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious)
      .Range("A" & FoundData.Row & ":H" & iLastRow).Copy .Cells(iLastRow + 1, 1)
       .Cells(iLastRow + 2, 1) = .Cells(FoundData.Row + 1, 1) + 1
    End With
  Next
End Sub
Удаление одинаковых пар в двух столбцах
 
Вот теперь нормально. Всего доброго!
Удаление одинаковых пар в двух столбцах
 
Nordheim,
И количество по вашему варианту не совпадает, например
Сыр Печенье 2     а д.б. 8
Удаление одинаковых пар в двух столбцах
 
Nordheim,
Цитата
If arr(i, 1) > arr(i, 2) Then
А что в массивах можно СЫР сравнивать с ПЕЧЕНЬЕМ ?
Как это происходит?
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 233 След.
Наверх