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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 229 След.
Поиск и копирование по условию двух ячеек, Поиск по значениям двух ячеек первого листа во втором листе и копирование обеих строк на третий лист
 
У меня тоже получилось больше совпадений
Код
'запускать при активном листе Лист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
Автозаполнение через форму с прогрессией
 
Цитата
хочу сделать автозаполнение с прогрессией
Код
Private Sub CommandButton1_Click()
rk = Sheets("Лист1").Columns("A").Rows(65000).End(xlUp).Row + 1
With Sheets("Лист1")
  .Cells(rk, 1).Resize(Me.TextBox2.Value) = Me.TextBox1.Value
  .Cells(rk, 2) = 1
  .Cells(rk, 2).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
       Step:=1, Stop:=Me.TextBox2.Value
End With
End Sub
Пронумеровать группы ячеек
 
Цитата
Подскажите пожалуйста формулу
Я формулой не умею.
Попробуйте макрос
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim n As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("B1:B" & iLastRow).ClearContents
  For i = 1 To iLastRow
    If Cells(i, "A").Interior.ColorIndex = 6 Then
      Cells(i, "B") = 1
      n = 1
      Do While Cells(i + n, "A").Interior.ColorIndex = Cells(i, "A").Interior.ColorIndex
        If i + n > iLastRow Then Exit For
        Cells(i + n, "B") = n + 1
        n = n + 1
      Loop
      i = i + n - 1
    End If
  Next
End Sub
Скрыть строки с нулевыми значениями во всей книге, Не могу разобраться как применить макрос ко всей книге
 
Код
Sub Скрытьстрок()
    Dim ws As Worksheet
    Dim i As Long
    Dim j As Long
    Application.ScreenUpdating = False
    For j = 2 To ThisWorkbook.Worksheets.Count
        Set ws = ThisWorkbook.Worksheets(j)
        If ws.Name <> "СВОД" Then
          With ws
            For i = 15 To 92
                If (.Cells(i, "G").Value = "") Or (.Cells(i, "G").Value = 0) Then
                    .Rows(i).Hidden = True
                Else
                    .Rows(i).Hidden = False
                End If
            Next i
          End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub
Выбор из текста в ячейке данных по конкретным парметрам
 
Для площади UDF
Код
Function iSquare(cell$)
Dim mo As Object
Dim n As Integer
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "[\d ]+(,\d+)?(?= кв.м.)"
     If .Test(cell) Then
      Set mo = .Execute(cell)
      For n = 0 To mo.Count - 1
        iSquare = iSquare & mo(n) & ";" & Chr(10)
      Next
        iSquare = Left(iSquare, Len(iSquare) - 2)
     End If
 End With
End Function
Перенос строк с форматированием и формулами конечного файла
 
Пишу  с планшета. Скопируйте строку одной книги, а затем встаьте в другую при помощи специальной вставки. Удачи!
Cоздание массива дат из произвольных интервалов дат
 
Olegio555,
Цитата
Введённые интервалы могут пересекаться. Оч нужно, чтобы разбивка адекватно это воспринимала.
Похоже, что вы проигнорировали решение макросом. Ну это ваше дело.
Цитата
чтобы она подтягивала и множила в нужном объёме ещё и строчку,
Добавил в макрос эту вашу хотелку. Для примера из сообщения #7
Код
Sub iDataSeries()
Dim iLastRow As Long
Dim iLR As Long
Dim i As Long
   iLastRow = Cells(Rows.Count, "E").End(xlUp).Row + 1
   Range("E2:F" & iLastRow).ClearContents
   iLR = Cells(Rows.Count, "B").End(xlUp).Row
 For i = 2 To iLR
   iLastRow = Cells(Rows.Count, "E").End(xlUp).Row + 1
   Cells(iLastRow, "E") = Cells(i, "B")
   Cells(iLastRow, "F").Resize(Cells(i, "C") - Cells(i, "B") + 1) = Cells(i, "D")
   Cells(iLastRow, "E").DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:= _
        xlDay, Step:=1, Stop:=Cells(i, "C"), Trend:=False
 Next
   iLastRow = Cells(Rows.Count, "E").End(xlUp).Row
    Range("E2:E" & iLastRow).NumberFormat = "dd.mmm"
End Sub
Перенос строк с форматированием и формулами конечного файла
 
Скопировали диапазон Range1, затем вставляете в нужное место при помощи PasteSpecial
Код
Range1.Copy
Cells(1,1)..PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Почитайте справку про .PasteSpecial, вам ведь еще значения или формулы надо вставлять, или ширину столбцов.
Создание динамического самообновляемого отчёта по периодам
 
У меня ваш архив не открылся, так что мыслей пока нет!
Перенос строк с форматированием и формулами конечного файла
 
Цитата
как переносить данные с форматирование
Код
Range.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                                        SkipBlanks:=False, Transpose:=False
Копирование строк в таблице в зависимости от числа в ячейке, Задача размножить строки в зависимости от числа в ячейке
 
Недавно решали подобную задачу https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=125719
При выборе исполнения выводить все входящие в это исполнение чертежи комплектующих
 
Цитата
таблица, в которой в зеленое поле вводится номер исполнения
Макрос в модуль листа Лист1, срабатывает при изменении значения в ячейке АА3
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("AA3")) Is Nothing Then
    Application.EnableEvents = False
Dim FoundCell As Range
Dim FAdr As String
Dim FoundNomer As Range
Dim iLastRow As Integer
Dim iStart As Long
Dim iEnd As Long
Dim j As Integer
   iLastRow = Cells(Rows.Count, "AB").End(xlUp).Row + 1
   If iLastRow >= 4 Then Range("AB4:AD" & iLastRow).Clear
    Set FoundCell = Columns(5).Find("Обозн. исполн.", , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then         'нашли Обозн. исполн.
      FAdr = FoundCell.Address
      Do
        Set FoundNomer = Range(Cells(FoundCell.Row, "F"), Cells(FoundCell.Row, "O")).Find(Target, , xlValues, xlWhole)
         If Not FoundNomer Is Nothing Then   'нашли номер исполнения
           iStart = FoundCell.Row + 1
           Set FoundCell = Columns(5).Find("Обозн. исполн.", After:=FoundCell)
           If FoundCell.Address = FAdr Then
             iEnd = Cells(Rows.Count, "E").End(xlUp).Row
           Else
             iEnd = FoundCell.Row - 1
           End If
           For j = iStart To iEnd   'цикл по документации выбранного номера исполнения
             If IsNumeric(Cells(j, FoundNomer.Column)) Then
               iLastRow = Cells(Rows.Count, "AB").End(xlUp).Row + 1
               Cells(iLastRow, "AB") = Cells(j, "D")                 'чертеж
               Cells(iLastRow, "AC") = Cells(j, "E")                 'наименование
               Cells(iLastRow, "AD") = Cells(j, FoundNomer.Column)   'количество
             End If
           Next
             iLastRow = Cells(Rows.Count, "AB").End(xlUp).Row
             Range("AB4:AD" & iLastRow).Borders.Weight = xlThin      'границы
             Exit Do
         End If
         Set FoundCell = Columns(5).Find("Обозн. исполн.", After:=FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
 End If
  Application.EnableEvents = True
End Sub
Подсчет количества позиций по всем файлам Excel в корневой папке
 
Если порядковые номера будут в виде чисел в столбце А , то макрос в файл Свод
В диалоговом окне выберите папку со сметами
Код
Sub SborFromFolder()
Dim FileName As String
Dim iPath As String
Dim Wb As Object
Dim CurWb As Worksheet
Dim iLR As Long
Dim n As Integer
    Application.ScreenUpdating = False
    Set CurWb = ThisWorkbook.Worksheets("Лист1")
    Rows("4:" & Rows.Count).Clear
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку со сметами": .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        iPath = .SelectedItems(1) & "\"
    End With
    FileName = Dir(iPath & "*.xls*")
      n = 1
    Do While FileName <> ""
     Set Wb = Workbooks.Open(iPath & FileName)
       iLR = CurWb.Cells(CurWb.Rows.Count, "A").End(xlUp).Row + 1
       CurWb.Cells(iLR, "A") = n
       CurWb.Cells(iLR, "B") = Split(Wb.Name, ".")(0)
       CurWb.Cells(iLR, "C") = Application.CountIf(Columns(1), ">0") - 1
        Wb.Close: FileName = Dir
        n = n + 1
    Loop
      iLR = Cells(Rows.Count, "A").End(xlUp).Row
      Range("A4:C" & iLR).Borders.Weight = xlThin
      Cells(iLR + 2, "B") = "Итого:"
      Cells(iLR + 2, "C") = WorksheetFunction.Sum(Range("C4:C" & iLR))
End Sub
Автоподбор высоты строки объединенной ячейки
 
macrofag, написал
Цитата
Макрос прилагаю.
И где он?
Как удалить пробел в дробном числе
 
Forestwarden,
В коде от buchlotnik кавычки не той системы
Код
change = .Replace(t, "$1$3")
Разбить записи (строки) в журнале на несколько записей (от количества дней) разделив объем на количество дней
 
Код
Sub RazdelitStroki()
Dim i As Long
Dim iLastRow As Long
Dim n As Long
    iLastRow = Range("B9").End(xlDown).Row
    For i = iLastRow To 10 Step -1
      Rows(i + 1).Resize(Cells(i, "I").Value).Insert
      Cells(i, "F") = Cells(i, "F") / Cells(i, "I").Value
      Cells(i, "F").NumberFormat = "#,##.##"
      Range(Cells(i, "B"), Cells(i, "G")).Resize(Cells(i, "I").Value + 1).FillDown
        n = Cells(i, "I")
      Do
        Cells(i + n, "G") = Cells(i, "G") + n - 1
        n = n - 1
      Loop While n > 0
    Next
    iLastRow = Range("B9").End(xlDown).Row
    Range("B10:I" & iLastRow).Borders.Weight = xlThin
End Sub
Разбить записи (строки) в журнале на несколько записей (от количества дней) разделив объем на количество дней
 
Цитата
Правда даты не ставит(
Какие даты?
Назначить область печати с условием
 
Код
ActiveSheet.PageSetup.PrintArea=Range("AJ15:BT47").Address
Разбить записи (строки) в журнале на несколько записей (от количества дней) разделив объем на количество дней
 
Для активного листа 'Пример для понимания'
Код
Sub RazdelitStroki()
Dim i As Long
Dim iLastRow As Long
Dim n As Long
    iLastRow = Range("B9").End(xlDown).Row
    For i = iLastRow To 10 Step -1
      Rows(i + 1).Resize(Cells(i, "I").Value).Insert
      Cells(i, "F") = Cells(i, "F") / Cells(i, "I").Value
      Cells(i, "F").NumberFormat = "#,##.##"
      Range(Cells(i, "B"), Cells(i, "G")).Resize(Cells(i, "I").Value + 1).FillDown
    Next
    iLastRow = Range("B9").End(xlDown).Row
    Range("B10:I" & iLastRow).Borders.Weight = xlThin
End Sub

Попробуйте сами перенести в реальную таблицу
Как данные номенклатуры из 1С в виде столбца с отступами преобразовать в структуру библиотеки
 
Посмотрите здесь, может поможет
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=103619
Разбить записи (строки) в журнале на несколько записей (от количества дней) разделив объем на количество дней
 
Посмотрите https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=125663
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 229 След.
Наверх