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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 230 След.
Макрос для диапазона условий "одинаковое название + заполненная ячейка"
 
Цитата
я не знаю, каким по счету и на каком листе он будет
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("C1")) Is Nothing Then
  Application.EnableEvents = False
Dim FoundCell As Range
Dim Sht As Worksheet
Dim iLastRow As Long
   For Each Sht In Worksheets
     If Sht.Name <> "Лист1" Then
       With Sht
         Set FoundCell = .Rows(1).Find(Target, , xlValues, xlWhole)
         If Not FoundCell Is Nothing Then
           'FoundCell.Column - столбец в котором нашли мероприятие
            iLastRow = .Cells(.Rows.Count, FoundCell.Column).End(xlUp).Row
            .Activate
            'ставите фильтр
            Application.EnableEvents = True
            Exit Sub
         End If
       End With
     End If
   Next
 End If
  Application.EnableEvents = True
End Sub
Макрос для диапазона условий "одинаковое название + заполненная ячейка"
 
Цитата
хотя бы наведёт на мысль.
Пишите макрос на изменение содержимого ячейки С1 на первом листе
далее поиск по всем листам в строке 1 нужного мероприятия
перенос содержимого столбца на первый лист
Перенос данных из ячеек одного документа в ячейки другого документа c определенным шагом. VBA, Макрос VBA
 
EleeSha,
Цитата
если строка в"Актуальный график" содержит слова "ФИО/Должность",
В макросе находим начало диапазона BeginRow и конец EndRow,
в цикле переносите этот диапазон куда нужно
Код
Sub iFIO()
Dim FoundCell As Range
Dim FAdr As String
Dim BeginRow As Long
Dim EndRow As Long
    Set FoundCell = Columns("B:D").Find("ФИО/Должность", , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      BeginRow = FoundCell.Row + 2
      Do
       EndRow = Range("B" & BeginRow).End(xlDown).Row
       'первый диапазон строка 19 - строка 51 (потом 174-185) и т.д.
       'переносите этот диапазон куда нужно
       Set FoundCell = Columns("B:D").FindNext(FoundCell)
       BeginRow = FoundCell.Row + 2
      Loop While FoundCell.Address <> FAdr
     End If
End Sub
Как суммировать, если суммируемые элементы находятся не на одной строке.
 
ПРОИЗВЕД,
А мне интересно посмотреть на исходный пдф файл,  после преобразования которого получилась такая простыня.
Как суммировать, если суммируемые элементы находятся не на одной строке.
 
Цитата
как суммировать
Макросом
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iDict As Object
Dim n As Integer
Dim Kol As Integer
Dim arr
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  Range("D2:E1000").ClearContents
    Set iDict = CreateObject("Scripting.Dictionary")
 With iDict
     .CompareMode = 1
  For i = 3 To iLastRow
    Kol = Cells(i, 1).MergeArea.Count
    Cells(i, 1) = Replace(Cells(i, 1), Chr(10), "")
    arr = Split(Cells(i, 1), ",")
      For n = 0 To UBound(arr)
        If arr(n) <> " " Then
            .Item(WorksheetFunction.Trim(arr(n))) = .Item(WorksheetFunction.Trim(arr(n))) _
            + WorksheetFunction.Sum(Range(Cells(i, 2), Cells(i + Kol - 1, 2)))
        End If
      Next
     i = i + Kol - 1
  Next
   Cells(2, 4).Resize(.Count) = Application.Transpose(.Keys)
   Cells(2, 5).Resize(.Count) = Application.Transpose(.Items)
 End With
End Sub
Как суммировать, если суммируемые элементы находятся не на одной строке.
 
Можете привести пример .pdf файла, попробую его конвертировать, посмотрю, что получится.
Как суммировать, если суммируемые элементы находятся не на одной строке.
 
Цитата
Есть листы объемов работ в пдф, после конвертирования в эксель-файлы таблицы выжили
Каким конвертером пользовались?
В формулы подставить вместо ссылок их значения
 
Код
Cells(2, 2) = [B1] & "+" & [C1] & "-" & [D1] & "=" & [B1] + [C1] - [D1]
Динамический зависящий выпадающий список
 
Посмотрите
https://www.planetaexcel.ru/techniques/1/
Прописать Макрос по трансформации даты 27 грудня 2019 року на 27.12.2019, если даты, месяц и год разные по всему столбце
 
Isobev,
Цитата
Но полезла проблема №2
формат ячейки Дата, Тип *14.03.2001
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iDateMonth As String
   iLastRow = Cells(Rows.Count, "I").End(xlUp).Row
   Range("J6:J" & iLastRow).ClearContents
   Range("I6:I" & iLastRow).Replace "р.", ""
   Range("I6:I" & iLastRow).Replace " р", ""
   Range("I6:I" & iLastRow).Replace ".", ""
   Range("I6:I" & iLastRow).Replace "року", ""
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "[іа-я]+"
  For i = 6 To iLastRow
   If Not IsDate(Cells(i, "I")) And Not IsEmpty(Cells(i, "I")) Then
     iDateMonth = .Execute(Cells(i, "I"))(0)
    Select Case iDateMonth
     Case "січня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " января "))
     Case "лютого": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " февраля "))
     Case "березня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " марта "))
     Case "квітня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " апреля "))
     Case "травня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " мая "))
     Case "червня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " июня "))
     Case "липня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " июля "))
     Case "серпня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " августа "))
     Case "вересня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " сентября "))
     Case "жовтня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " октября "))
     Case "листопада": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " ноября "))
     Case "грудня": Cells(i, "J") = CDate(.Replace(Cells(i, "I"), " декабря "))
    End Select
   Else
     If Not IsEmpty(Cells(i, "I")) Then
       Cells(i, "J") = CDate(Cells(i, "I"))
     End If
   End If
  Next
 End With
End Sub
Изменено: Kuzmich - 26 Фев 2020 11:56:58
Сложный перевод колонок в строки
 
Цитата
работал бы с любым количеством строк и столбцов,
Количество строк макрос учитывает.
Надо найти последний заполненный столбец и использовать это значение в макросе,
попробуйте это сделать сами. Удачи!
Прописать Макрос по трансформации даты 27 грудня 2019 року на 27.12.2019, если даты, месяц и год разные по всему столбце
 
Цитата
там где ячейки объединенные, просто вручную пересматриваю, я так поняла по другому не получиться
Строки типа 76, 143 и т.д ( с объединенными ячейками) можно удалить макросом. Попробуйте удалить такие строки
вручную, а затем уже запустить макрос.
Сложный перевод колонок в строки
 
Кирилл Демидов,
Макроса в вашем файле так и не увидел.
Вот адаптированный для вашего файла макрос
Код
Sub ConvertTablica()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
 iLastRow = Range("A3").End(xlDown).Row
    iLR = 40
  For i = 2 To iLastRow
    Cells(i, "A").Copy Cells(iLR, "A")
    Range("B1:Q1").Copy
    Cells(iLR, "B").PasteSpecial xlPasteFormats, Transpose:=True
    Cells(iLR, "B").PasteSpecial xlPasteValues, Transpose:=True
    Range("B" & i & ":Q" & i).Copy
    Cells(iLR, "C").PasteSpecial xlPasteFormats, Transpose:=True
    Cells(iLR, "C").PasteSpecial xlPasteValues, Transpose:=True
    iLR = iLR + 16
  Next
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    With Range("A40:A" & iLastRow)
      .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
      .Value = .Value
    End With
      Range("A40:A" & iLastRow).Borders.Weight = xlThin
End Sub
Сложный перевод колонок в строки
 
Кирилл Демидов,
А где в вашем файле мой макрос? Прежде чем говорить, что не работает
Сложный перевод колонок в строки
 
Кирилл Демидов,
А мой вариант не сработал?
Объединение выделенных ячеек построчно
 
Код
Sub iMergeCell()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Range("A1").End(xlDown).Row
  For i = 1 To iLastRow
    Range("A" & i & ":B" & i).MergeCells = True
    Range("A" & i).HorizontalAlignment = xlCenter
  Next
End Sub
Сложный перевод колонок в строки
 
Код
Sub ConvertTablica()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
 iLastRow = Range("A3").End(xlDown).Row
    iLR = 14
  For i = 4 To iLastRow
    Cells(i, "A").Copy Cells(iLR, "A")
    Range("B3:D3").Copy
    Cells(iLR, "B").PasteSpecial xlPasteFormats, Transpose:=True
    Cells(iLR, "B").PasteSpecial xlPasteValues, Transpose:=True
    Range("B" & i & ":D" & i).Copy
    Cells(iLR, "C").PasteSpecial xlPasteFormats, Transpose:=True
    Cells(iLR, "C").PasteSpecial xlPasteValues, Transpose:=True
    iLR = iLR + 3
  Next
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    With Range("A14:A" & iLastRow)
      .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
      .Value = .Value
    End With
      Range("A14:A" & iLastRow).Borders.Weight = xlThin
End Sub
Нужно импортировать данные из одного файла в другой
 
Кросс http://www.excelworld.ru/forum/10-44206-1
Курсы валют НБУ импортировать и сделать обновляемыми
 
Я вам написал в той теме - удалить строки с этими объединенными ячейками и запустить макрос.
Что не получилось?
Курсы валют НБУ импортировать и сделать обновляемыми
 
А прошлую тему: Прописать Макрос по трансформации даты 27 грудня 2019 року на 27.12.2019, если даты, месяц и год разные по всему столбце
вы забросили?
Поиск и копирование по условию двух ячеек, Поиск по значениям двух ячеек первого листа во втором листе и копирование обеих строк на третий лист
 
У меня тоже получилось больше совпадений
Код
'запускать при активном листе Лист1
Sub iFind_Copy()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim List3 As Worksheet
  Set List3 = ThisWorkbook.Worksheets("Лист3")
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   List3.Cells.Clear
 With Worksheets("Лист2")
  For i = 2 To iLastRow
    Set FoundCell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
        If FoundCell.Offset(, 1) = Cells(i, "B") Then
          iLR = List3.Cells(List3.Rows.Count, "A").End(xlUp).Row + 2
          List3.Cells(iLR, "A") = "Лист1"
          Range("A" & i & ":K" & i).Copy List3.Cells(iLR, "B")
          List3.Cells(iLR + 1, "A") = "Лист2"
          .Range("A" & FoundCell.Row & ":K" & FoundCell.Row).Copy List3.Cells(iLR + 1, "B")
        End If
     End If
  Next
 End With
End Sub
Как выбрать дату из текста в ячейке.
 
Цитата
чтобы в полученной дате число дня проставлялась 1
UDF
Код
Function iDate(cell As String)
Dim re As Object
    Set re = CreateObject("vbscript.regexp")
    re.Pattern = "\d\d\.\d\d\.\d\d\d\d"
    If re.test(cell) Then
      iDate = "01" & Mid(re.Execute(cell)(0), 3)
      iDate = Format(iDate, "MMM YY")
    End If
End Function
Суммирование диапазона с выделением цифр из строк по условию
 
Для р
Код
Sub iSumma_р()
Dim j As Long
 With CreateObject("VBScript.RegExp")
   .Pattern = "р\d"
  For j = 1 To 5
     If .test(Cells(3, j)) Then
       Cells(3, 7) = Cells(3, 7) + Mid(.Execute(Cells(3, j))(0), 2)
     End If
   Next
 End With
End Sub
Перенести заливку из диапазона одного размера в диапазон другого размера
 
Цитата
перенести заливку
Не используя столбец I (ID) на вкладке Кандалакша
Код
'запускать при активном листе 1
Sub Zalivka()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Application.ScreenUpdating = False
 With Worksheets("Кандалакша")
   iLastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
   .Range("K4:V" & iLastRow).Interior.ColorIndex = xlNone
     iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 1 To iLastRow
    Set FoundCell = .Columns(4).Find(Split(Cells(i, "A"), "@")(0), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
        If CStr(FoundCell.Offset(, 1)) = Split(Cells(i, "A"), "@")(1) And _
           CStr(FoundCell.Offset(, 3)) = Split(Cells(i, "A"), "@")(2) Then
           Range("B" & i & ":M" & i).Copy
           FoundCell.Offset(, 7).PasteSpecial xlPasteFormats
        End If
       Set FoundCell = .Columns(4).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
  Next
 End With
Application.ScreenUpdating = True
End Sub
Перенести заливку из диапазона одного размера в диапазон другого размера
 
maria_gug, Доброе утро!
Зачем на вкладке Кандалакша два столбца с Корпус
Цитата
из диапазона одного размера в диапазон другого размера
Размер вроде одинаковый - 12 ячеек
На вкладке 1 адрес в виде "50 Лет Октября@8@0" Это так мой конвертер преобразовал?
Или адрес действительно в таком виде? Это улица 50 Лет Октября, дом 8, корпус 0
Переход макросом по строке на количесво столбцов по условию
 
Еще надо сделать проверку на то, что в ячейке К5 именно число и смещение не выйдет за пределы столбцов. Удачи!
Переход макросом по строке на количесво столбцов по условию
 
Цитата
как переместиться от ячейки N5 на кол-во ячеек вправо из K5) :
Код
Range"N5").Offset(,[K5])
Прописать Макрос по трансформации даты 27 грудня 2019 року на 27.12.2019, если даты, месяц и год разные по всему столбце
 
Isobev,
В таблице удалите объединенные ячейки (типа строк 76, 143 и т.д.)
В столбце I макрос убрает р. и року
Результат в столбце J
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iDateMonth As String
 iLastRow = Cells(Rows.Count, "I").End(xlUp).Row
 Range("J6:J" & iLastRow).ClearContents
 Range("I6:I" & iLastRow).Replace "р.", ""
 Range("I6:I" & iLastRow).Replace "року", ""
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "\s?[іа-я]+\s?"
  For i = 6 To iLastRow
   If Not IsDate(Cells(i, "I")) And Not IsEmpty(Cells(i, "I")) Then
     iDateMonth = .Execute(Cells(i, "I"))(0)
    Select Case iDateMonth
     Case " січня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".01.")
     Case " лютого ": Cells(i, "J") = .Replace(Cells(i, "I"), ".02.")
     Case " березня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".03.")
     Case " квітня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".04.")
     Case " травня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".05.")
     Case " червня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".06.")
     Case " липня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".07.")
     Case " серпня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".08.")
     Case " вересня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".09.")
     Case " жовтня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".10.")
     Case " листопада ": Cells(i, "J") = .Replace(Cells(i, "I"), ".11.")
     Case " грудня ": Cells(i, "J") = .Replace(Cells(i, "I"), ".12.")
    End Select
      Cells(i, "J").NumberFormat = "dd.mm.yyyy"
   Else
     Cells(i, "J") = Cells(i, "I")
     Cells(i, "J").NumberFormat = "dd.mm.yyyy"
   End If
  Next
 End With
End Sub

В ячейках типа 11січня 2019 надо вставить пробел 11 січня 2019
Изменено: Kuzmich - 21 Фев 2020 14:02:47
Прописать Макрос по трансформации даты 27 грудня 2019 року на 27.12.2019, если даты, месяц и год разные по всему столбце
 
Isobev,
Как прописываются остальные недостающие месяцы: февраль(лютня), март(березня) и т.д.
В строке 14 написано 11січня 2019 - нет пропуска между датой и месяцем
Автозаполнение через форму с прогрессией
 
Код
Private Sub CommandButton1_Click()
  rk = Sheets("Лист1").Columns("A").Rows(65000).End(xlUp).Row + 2
With Sheets("Лист1")
  .Cells(rk, 1).Resize(Val(Me.TextBox2)) = Me.TextBox1.Value
End With
End Sub

Private Sub CommandButton2_Click()
  rk = Sheets("Лист1").Columns("B").Rows(65000).End(xlUp).Row + 2
With Sheets("Лист1")
  .Cells(rk, 2) = Val(Me.TextBox3)
  .Cells(rk, 2).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
       Step:=1, Stop:=Val(Me.TextBox3) + Val(Me.TextBox4) - 1
End With
End Sub
Изменено: Kuzmich - 20 Фев 2020 18:38:23
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 230 След.
Наверх