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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 206 След.
Перестановка слов в ячейке
 
Цитата
нужно произвести перестановку фамилий из-за скобок в скобки
А где скобки в исходнике?
Удалить строки(не полностью) от столбца А до F там где пустые ячейки в столбце А., Если в столбце A встречается пустая ячейка, то удалять диапазон от A до F на этой строке
 
Код
Sub DelRow()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Range("A:F").Find("*", Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious).Row
  For i = iLastRow To 1 Step -1
    If Cells(i, "A") = "" Then Range("A" & i & ":F" & i).Delete Shift:=xlUp
  Next
End Sub
Что надо добавить в макрос что бы ячейки копировались и вставлялись без формул
 
Код
Range("A1:B1").Copy
.Cells(LastRow + 1, 6).PasteSpecial xlPasteValues
Что надо добавить в макрос что бы ячейки копировались и вставлялись без формул
 
Код
.Cells(LastRow + 1, 6).PasteSpecial xlPasteValues
Покрасить ячейки по названию
 
Цитата
Вообщем так как ничего не получилось сделать
А мой макрос вы попробовали?
Покрасить ячейки по названию
 
В модуль листа
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("B142:B143")) Is Nothing Then
        Application.EnableEvents = False
Dim i As Long
Dim arr
        Range("B1:B143").Interior.ColorIndex = xlColorIndexNone
        arr = Split(Split(Split(Target.Formula, "(")(1), ")")(0), ",")
        For i = 0 To UBound(arr)
          Range(arr(i)).Interior.ColorIndex = 6
        Next
    End If
    Application.EnableEvents = True
End Sub
Изменено: Kuzmich - 19 Фев 2019 17:15:05
Удалить текст до определенного символа
 
Цитата
нужно удалить весь текст который идет после первого символа : и сам первый символ
Цитата
чтобы осталось слово2:слово3
Мне кажется, что одно противоречит другому
Сопоставление данных из нескольких массивов, Выбор данных из нескольких массивов
 
Цитата
Есть данные по расписанию врачей
Могут ли быть дубликаты ФИО?
Вычисления над значениями через запятую, Необходимо выделить значения через запятую и произвести над ними вычисления
 
Цитата
не просуммировать, а просто вывести также через запятую
Код
Sub iSumma()
Dim i As Long
Dim j As Long
Dim arr
Dim FoundKod As Range
    Range("G12:G15").ClearContents
  For i = 12 To 15
      arr = Split(Cells(i, "B"), ",")
    For j = 0 To UBound(arr)
      Set FoundKod = Range("B2:B7").Find(arr(j), , xlValues, xlWhole)
      'Cells(i, "G") = Cells(i, "G") + FoundKod.Offset(, 1) 'для суммы
      Cells(i, "G") = Cells(i, "G") & FoundKod.Offset(, 1) & ","
    Next
      Cells(i, "G") = Left(Cells(i, "G"), Len(Cells(i, "G")) - 1)
      Cells(i, "G").NumberFormat = "@"
  Next
End Sub
Вычисления над значениями через запятую, Необходимо выделить значения через запятую и произвести над ними вычисления
 
Код
Sub iSumma()
Dim i As Long
Dim j As Long
Dim arr
Dim FoundKod As Range
    Range("G12:G15").ClearContents
  For i = 12 To 15
      arr = Split(Cells(i, "B"), ",")
    For j = 0 To UBound(arr)
      Set FoundKod = Range("B2:B7").Find(arr(j), , xlValues, xlWhole)
      Cells(i, "G") = Cells(i, "G") + FoundKod.Offset(, 1)
    Next
  Next
End Sub
Вычисления над значениями через запятую, Необходимо выделить значения через запятую и произвести над ними вычисления
 
Почему в G12=1, если для кода г масса=3 ?
Подсчет уникальных значение
 
Цитата
Может быть - "не правельно" пробовал...
Точно, надо правильно
VBA последний заполненный столбец в диапазоне.
 
Код
lLastRow = Cells.Find("*", [A1], xlValues, , xlByRows, xlPrevious).Row
lLastCol = Cells.Find("*", [A1], xlValues, , xlByColumns, xlPrevious).Column
Повторение значения n раз в другом столбце
 
Код
Sub Re()
Dim iR As Long
  iRow = Range("I11").End(xlDown).Row
  iR = 11
    For Each cell In Range(Cells(11, "I"), Cells(iRow, "I"))
      Range(Cells(iR, "M"), Cells(iR + cell.Value - 1, "M")) = cell.Offset(0, -1).Value
      iR = Cells(Rows.Count, "M").End(xlUp).Row + 1
    Next
End Sub
Почему при использовании метода Find ошибка: Run-time error '91'
 
Код
Sub find_1()
Dim width As Long
Dim W_Object As Object
 With ActiveSheet
  Set W_Object = Rows(2).Find(What:="П", LookIn:=xlValues, SearchOrder:=xlByRows)
   If Not W_Object Is Nothing Then width = W_Object.Column
 End With
End Sub
Копирование данных на другой лист по условию
 
Макрос в стандартный модуль
Код
'запуск макроса с активного листа Лист1
Sub iPerenos()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim KDB As Worksheet
  Set KDB = ThisWorkbook.Worksheets("Как должно быть")
   KDB.Range("D5:AG4000").ClearContents   'очистить диапазон на листе "Как должно быть"
 With Worksheets("Лист2")
   iLR = Cells(Rows.Count, "D").End(xlUp).Row
   iLastRow = 5   'первая строка для заполнения на листе "Как должно быть"
  For i = 5 To iLR
    Set FoundCell = .Columns(4).Find(Cells(i, "D"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
       .Cells(FoundCell.Row, "D").Copy KDB.Cells(iLastRow, "D")
       .Cells(FoundCell.Row, "G").Copy KDB.Cells(iLastRow, "R")
       .Cells(FoundCell.Row, "I").Copy KDB.Cells(iLastRow, "T")
       .Cells(FoundCell.Row, "J").Copy KDB.Cells(iLastRow, "U")
       .Cells(FoundCell.Row, "L").Copy KDB.Cells(iLastRow, "V")
       .Cells(FoundCell.Row, "N").Copy KDB.Cells(iLastRow, "W")
       .Cells(FoundCell.Row, "O").Copy KDB.Cells(iLastRow, "X")
       .Cells(FoundCell.Row, "Q").Copy KDB.Cells(iLastRow, "Y")
       .Cells(FoundCell.Row, "S").Copy KDB.Cells(iLastRow, "Z")
       .Cells(FoundCell.Row, "U").Copy KDB.Cells(iLastRow, "AC")
       .Cells(FoundCell.Row, "V").Copy KDB.Cells(iLastRow, "AG")
         iLastRow = KDB.Cells(KDB.Rows.Count, "D").End(xlUp).Row + 1
       Set FoundCell = .Columns(4).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
  Next
 End With
End Sub
Поиск совпадений в текста в ячейке и нахождение ее координат
 
Да find возвращает range при наличии Set, но у вас было
Код
Find("фыва", , xlValues, xlPart).Row
Поиск совпадений в текста в ячейке и нахождение ее координат
 
Вы определили Dim fcell As Range
Поиск совпадений в текста в ячейке и нахождение ее координат
 
Код
Sub kkk()
Dim fcell As Range
  Set fcell = ThisWorkbook.Worksheets("Лист1").Columns("C").Find("фыва", , xlValues, xlPart)
  MsgBox fcell.Address
End Sub
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
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 206 След.
Наверх