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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 229 След.
Автозаполнение через форму с прогрессией
 
Цитата
хочу сделать автозаполнение с прогрессией
Код
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
Подсчет количества позиций по всем файлам Excel в корневой папке
 
bikeza,
Цитата
такое иногда бывает, к сожалению это никак не отследить, так как смет сотни и в каждой сотни позиций
К сожалению, именно на подсчете порядковых номеров в виде чисел в столбце А смет можно было посчитать количество позиций по каждой смете
Cоздание массива дат из произвольных интервалов дат
 
Olegio555,
Извините, макросом
Код
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:E" & iLastRow).ClearContents
   iLR = Cells(Rows.Count, "A").End(xlUp).Row
 For i = 2 To iLR
   iLastRow = Cells(Rows.Count, "E").End(xlUp).Row + 1
   Cells(iLastRow, "E") = Cells(i, "A")
   Cells(iLastRow, "E").DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:= _
        xlDay, Step:=1, Stop:=Cells(i, "B"), Trend:=False
 Next
    Range("E2:E" & iLastRow).NumberFormat = "dd.mmm"
End Sub
Подсчет количества позиций по всем файлам Excel в корневой папке
 
Похоже мои вопросы проигнорировали - всего доброго!
Количество строк в группировке
 
Цитата
количество строк в каждой группировке
Не совпала сумма по клиенту 4
Вывел отдельно сумму в столбец H
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iBegin As Long
Dim iEnd As Long
Dim n As Integer
    iLastRow = Cells(Rows.Count, "F").End(xlUp).Row
    Range("G2:H" & iLastRow).ClearContents
    iBegin = 2
  For i = 2 To iLastRow
      n = 0
      iEnd = iBegin
    Do While Cells(iEnd + 1, "A").IndentLevel = 4 And iEnd <= iLastRow
      iEnd = iEnd + 1
      n = n + 1
    Loop
      Cells(iBegin, "G") = n
      Cells(iBegin, "H") = WorksheetFunction.Sum(Range(Cells(iBegin + 1, "F"), Cells(iEnd, "F")))
      Cells(iBegin, "H").NumberFormat = "#,##0.00"
    iBegin = iEnd + 1
    i = iEnd + 1
  Next
End Sub
Аналог Application.Trim
 
Был код в сообщении #13, сам видел, прошло полчаса и пропал. Как так?
Аналог Application.Trim
 
RAN,
Спасибо Андрей!
Аналог Application.Trim
 
Цитата
трюк весьма интересный
В части кода из сообщения #8 у меня одного пусто?
добавить строки относительно заданного значения в ячейке, добавить строки относительно заданного значения в ячейке
 
Макрос в стандартный модуль. Запускать при активном листе "что есть "
добавить строки относительно заданного значения в ячейке, добавить строки относительно заданного значения в ячейке
 
Цитата
сделать при помощи макроса
Код
Sub InsertRows()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
 iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
 With Worksheets("что нужно получить ")
 .Cells.Clear
 iLR = 1
  For i = 2 To iLastRow
    .Cells(iLR, "A") = Cells(i, "C")
    .Cells(iLR, "B") = Cells(i, "B")
    .Rows(iLR + 1).Resize(Cells(i, "D").Value).Insert
    iLR = iLR + Cells(i, "D").Value + 1
  Next
 End With
End Sub
Аналог Application.Trim
 
А так
Код
Function AllTrim(iCell As Range) As String
    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
        With re
            .Global = True
            .Pattern = "\s+"
            AllTrim = Trim(.Replace(iCell, " "))
        End With
    Set re = Nothing
End Function
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 229 След.
Наверх