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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 205 След.
VBA: перенос столбцов в новый лист через столбец циклом
 
Цитата
Private Sub Worksheet_Activate()
При активации какого листа срабатывает макрос?
Цитата
Sheets("Лист1").Range("B1")
В книге нет Листа1
VBA: перенос столбцов в новый лист через столбец циклом
 
У меня ваш архив не открылся.
Нумерация строк сквозь объединенные ячейки
 
Код
Sub dfs()
Dim i%, n%, ilastrow&
   n = 1
  ilastrow = Cells(Rows.Count, 3).End(xlUp).Row
For i = 8 To ilastrow
  If Cells(i, 2).MergeCells = False Then
     Cells(i, 2) = n: n = n + 1
    With Cells(i, 2)
     .Font.Bold = False
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlCenter
    End With
  End If
Next
End Sub
Макрос суммирование ячеек из множества вкладок
 
Ищите цикл по листам
Цикл по менеджерам
Поиск - Find
Макрос суммирование ячеек из множества вкладок
 
Делаете цикл по ФИО и ищете (Find) каждую фамилию на нужных вкладках и суммируете данные в конкретых[ ячейках
Макрос суммирование ячеек из множества вкладок
 
Цитата
Не могли бы помочь с макросом или vba.
Вы полагаете, что это разные понятия?
Автоматизация заполнения формы, скачанной из Консультант+
 
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=75546

Видимо надо сделать цикл по ФИО, заполнить форму  на двух листах на каждую фамилию и сохранить файл с соответствующим именем  в какой-либо папке.
Для этого нужна база данных всех садоводов
Выхват и расположение в другой ячейке слов по шаблону.
 
Код
Sub iShablon()
Dim mo As Object
Dim n As Integer
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "дом..*?(?=,)"
     If .test(Cells(7, "D")) Then
         Range("N7") = ""
       Set mo = .Execute(Cells(7, "D"))
         For n = 0 To mo.Count - 1
           Range("N7") = Range("N7") & mo(n) & "+"
         Next
           Range("N7") = Left(Range("N7"), Len(Range("N7")) - 1)
    End If
 End With
End Sub
Регулярное выражение. Заменить Фамилию Имя Отчество на Фамилию И. О.
 
Андрей VG, А буковка Ё и ё ?
Макрос, копирующий строки опреденное количетсво раз.
 
При активном листе Pivot
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
 Range("E3") = Range("A3")
 Range("F3") = Range("B3")
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    n = 4
  For i = 4 To iLastRow
    Cells(n, "E").Resize(Cells(i, "C")) = Cells(i, "A")
    Cells(n, "F").Resize(Cells(i, "C")) = Cells(i, "B")
    n = n + Cells(i, "C")
  Next
End Sub
Изменено: Kuzmich - 13 Дек 2018 17:45:54
Подсчет строк в книге определенной заливки и определенного содержания
 
Цитата
_Igor_61 написал:
А по объединенным  решил побегать, т.к. заголовки могут неизвестного содержания быть
Можно цикл сделать по количеству (MergeArea.Count) объединенных ячеек, там 7, там 3
Подсчет строк в книге определенной заливки и определенного содержания
 
  Игорь!
В примере от ТС Заголовок - объединенная ячейка из 7 ячеек, а Наименование - объединенная ячейка из 3 ячеек
Поэтому в цикле по столбцу А все ячейки объединенные.
На листе Пример Наименование - одна ячейка
Подсчет строк в книге определенной заливки и определенного содержания
 
Реализация алгоритма, предложенного в сообщении #3
Код
Sub iЗаголовок()
Dim iLastRow As Long
Dim iText As String
Dim FRow As Integer
Dim ERow As Integer
Dim FoundCell As Range
Dim FAdr As String
Dim i As Integer
Dim n As Integer
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("N8:N" & iLastRow).ClearContents   'очищает столбец с результатом
  Set FoundCell = Columns("A:G").Find("Заголовок", , xlValues, xlPart)
   If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address            'адрес первого вхождения Заголовка
    Do
      iText = FoundCell.Text              'Заголовок с номером
      FRow = FoundCell.Row + 1            'первая строка после Заголовка
        Set FoundCell = Columns("A:G").Find("Заголовок", After:=FoundCell)
        If FoundCell.Address = FAdr Then
          ERow = iLastRow                 'последняя строка в диапазоне между Заголовками
        Else
          ERow = FoundCell.Row - 1
        End If
          n = 0
        For i = FRow To ERow              'цикл в диапазоне для подсчета количества окрашенных строк
          If Cells(i, "A").Interior.ColorIndex = Range("A8").Interior.ColorIndex Then n = n + 1
        Next
        Cells(FRow - 1, "N") = iText & " кол-во красных строк: " & n    'вывод результата в столбец N
    Loop While FoundCell.Address <> FAdr
   End If
End Sub
Результат в столбце N
Подсчет строк в книге определенной заливки и определенного содержания
 
Цитата
Как написать такой "проход", который начинает считать первую же строку под заголовком
Ищете слово Заголовок в столбцах A:G это будет начало диапазона, затем ищете следующее слово - это будет конец диапазона.
В этом диапазоне подсчитываете количество красных строк
По датам периода выделить диапазон ячеек и проставить в них значение
 
А что за диапазон Range("uch_god")?
Поиск по части текста
 
Цитата
Maranii написал:
Но проблема в том, что все ареса написаны по-разному (в первом случае у нас Энтузиастов ш 14, во втором шоссе Энтузиастов, д. 14)
Присвойте каждому адресу индивидуальный индекс и осуществляйте поиск по этому индексу и не будет проблем с адресами.
В Жилищном агентстве вашего района есть списки адресов и индексов для каждого дома, можете воспользоваться ими.
Открыть случайный лист
 
Код
Sub БилетСлуч()
  нижн_гран = 1
  верх_гран = 6
    Randomize
    ThisWorkbook.Worksheets("Б" & Int((верх_гран - нижн_гран + 1) * Rnd + нижн_гран)).Activate
End Sub
Проблема выбора значений по условию в фильтре сводной (Pagefield) с помощью VBA
 
Цитата
кто скинет русскоязычный гайд
На мой взгляд хорошей книгой по сводным таблицам является
"Билл Джелен. Применение VBA и макросов в Microsoft Excel. Бизнес решения. Москва, Спб, Киев, 2006 г."
Для 2007 "VBA и макросы в Microsoft Office Excel 2007 Билл Джелен, Трейси Сирстад", на сайте издательского дома "Вильямс" есть файлы к книге
http://archive.williamspublishing.com/cgi-bin/materials.cgi?isbn=5-8459-0882-5
Разделить текст по столбцам(содержание и наименования разные)
 
http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&TID=84380
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=101044
Разбивка данных из листа excel на новые книги по определенному признаку
 
  В макросе список уникальных городов формируется в столбце Н. Если у вас будет 10 столбцов, то формируйте список в любом столбце после 10-ого.
Поиск города в макросе идет в столбце С, если города будут в 4-ом столбце, то строка кода будет
Код
     Set FoundTown = Columns(4).Find(Town, , xlValues, xlWhole)
и дальше
Код
     Set FoundTown = IsxodList.Columns(4).FindNext(FoundTown)
В коде есть комментарии, попробуйте разобраться.
Разбивка данных из листа excel на новые книги по определенному признаку
 
Цитата
что нужно менять при изменении количества столбцов и строк в таблице
Сколько у вас будет столбцов?
В каком столбце будут города?
Количество строк в таблице определяется строкой кода
Код
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Разбивка данных из листа excel на новые книги по определенному признаку
 
Мой вариант макроса
Код
Sub Razbivka()
Dim iLastRow As Long
Dim iLR_Unic As Long
Dim i As Long
Dim Town As String
Dim FoundTown As Range
Dim FAdr As String
Dim n As Integer
Dim IsxodList As Worksheet
  'отключаем обновление экрана, предупреждения и автоматическое вычисление
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlManual
   Set IsxodList = ThisWorkbook.ActiveSheet
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("H1:H" & iLastRow).ClearContents
 Range("C1:C" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
    iLR_Unic = Cells(Rows.Count, 8).End(xlUp).Row
  For i = 2 To iLR_Unic    'цикл по уникальным городам
    Town = Cells(i, 8)     'очередной город
     Set FoundTown = Columns(3).Find(Town, , xlValues, xlWhole)
          If Not FoundTown Is Nothing Then               'нашли город в столбце С
            FAdr = FoundTown.Address                     'адрес первого вхождения
            Workbooks.Add (xlWBATWorksheet)              'создать книгу с одним листом
             IsxodList.Range("A1:C1").Copy Range("A1")   'копируем шапку
              n = 1
            Do
                n = n + 1
              IsxodList.Range("A" & FoundTown.Row & ":C" & FoundTown.Row).Copy Cells(n, "A")
              Columns("A:C").AutoFit
              Columns("B:B").HorizontalAlignment = xlLeft
                Set FoundTown = IsxodList.Columns(3).FindNext(FoundTown)
            Loop While FoundTown.Address <> FAdr
              ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Town & ".xls"
              ActiveWorkbook.Close SaveChanges:=True
          End If
  Next
'включаем все, что отключали
    .Calculation = xlAutomatic
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub
Разбивка данных из листа excel на новые книги по определенному признаку
 
Цитата
vera198907 написал:
нужно решить следующую задачу
   Макросом в каком-либо свободном столбце формируете уникальный список городов, встречающихся в столбце С,
затем делаете цикл по уникальным городам, создаете новую книгу с одним листом и ищете строки с очередным городом,
найденные строки переносите в новую книгу, книгу сохраняете с названием города.
[ Закрыто] Копирование диапазона ячеек с условием из выпадающего списка
 
Цитата
выбирается из выпадающего списка тип лодки
В А3 из выпадающего списка выбираете нужную лодку
В модуль листа Главная
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("A3")) Is Nothing Then
    Application.EnableEvents = False
Dim FoundLodka As Range
Dim iLastRow As Integer
Dim iLR As Integer
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    If iLastRow >= 3 Then Range("B3:C" & iLastRow).Clear
    With Worksheets("Данные")
      Set FoundLodka = .Rows(2).Find(Target, , xlValues, xlWhole)
      If Not FoundLodka Is Nothing Then
       iLR = .Cells(Rows.Count, FoundLodka.Column).End(xlUp).Row
       .Range(.Cells(3, FoundLodka.Column), .Cells(iLR, FoundLodka.Column + 1)).Copy Range("B3")
      Else
        MsgBox "На листе Данные нет комплектации для лодки " & Target
      End If
    End With
  End If
    Application.EnableEvents = True
End Sub
И послушайте совета из #7 по поводу написания типов лодок
Печать бланка, учитывая необходимое кол-во копий.
 
На листе Водители создаете кнопку и привязываете к ней макрос
Код
Sub Blank_Print()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
 With Worksheets("Бланк")
  For i = 3 To iLastRow
    .Range("B3") = Cells(i, "B")    'ФИО
    'заполняете Бланк (диапазон "A1:C13") из соответствующих ячеек листа Водители
    'число копий тоже берете из листа Водители
    '.Range("A1:C13").PrintOut Copies:=1, Collate:=True
  Next
 End With
End Sub
Печать бланка, учитывая необходимое кол-во копий.
 
Сделайте единый бланк для всех водителей, и циклом на листе Водители пройдите по всем фамилиям,
поочередно подставляя в Бланк ФИО, дату и номер листа и печатая этот Бланк для соответствующего водителя.
Печать бланка, учитывая необходимое кол-во копий.
 
  А для водителя Сырко в бланке места не нашлось?
И где ваши макросы?
Поиск в тексте хХ (рядом строчная и заглавная) и вставка между ними символа
 
Цитата
сначала идет маленькая буква потом большая и нет наличия пробела между ними.
UDF
Код
Function BukvaProbel(cell$)
 With CreateObject("VBScript.RegExp")
   .Global = True
   .Pattern = "[a-z][A-Z]"
   BukvaProbel = Left(cell, .Execute(cell)(0).FirstIndex + 1) & " " & Mid(cell, .Execute(cell)(0).FirstIndex + 2)
 End With
End Function
Подсчет количества ячеек с точной датой, которая входит в диапазон в другом списке
 
Создать сводную таблицу и сделать группировку по месяцам и годам
VBA: переместить данные и удалить опустевший столбец
 
Код
Sub iKod_Del_Row()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  For i = iLastRow To 10 Step -1
    If IsNumeric(Cells(i, "B")) Then
      Cells(i - 1, "A") = Cells(i, "B")
      Rows(i).Delete
    End If
  Next
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 205 След.
Наверх