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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 238 След.
Обращение к ячейкам в цикле по листам
 
Цитата
чтобы он брал данные с нужного листа
Используйте конструкцию
Код
With Worksheets("имя_нужного листа")
......
End With
Автозаполнение чередующихся значение со сдвигим вниз до последнего заполненого ряда
 
Mershik,
В Баден-Баден собрались?
Получить чистую площадь стен за вычетом проемов
 
А у БМВ разве не решение было?
Получить чистую площадь стен за вычетом проемов
 
Цитата
не отказывайтесь помогать будущим посетителям,
А мое потраченное время почему не учитывается? Мое сообщение скрыто, другие показываются. Непонятно.
Перевернуть текст и заменить буквы - реверс-комплемент
 
Код
Function ReverseText(strText As String) As String
  ReverseText = StrReverse(strText)
  ReverseText = Replace(ReverseText, "A", "R")
  ReverseText = Replace(ReverseText, "C", "Y")
  ReverseText = Replace(ReverseText, "T", "A")
  ReverseText = Replace(ReverseText, "G", "C")
  ReverseText = Replace(ReverseText, "R", "T")
  ReverseText = Replace(ReverseText, "Y", "G")
End Function
Получить чистую площадь стен за вычетом проемов
 
Habar26,
Получается, что только в столбце О наименование помещения может встречаться несколько раз?
Получить чистую площадь стен за вычетом проемов
 
Habar26,
Вы бы заполнили несколько позиций - что должно получится. Для облегчения понимания
Копирование на отдельный лист данных из выгрузки 1С, относящиеся к конкретному пункту ()10.01)
 
Юрий М,
ТС ту тему закрыл, открыв аналогичную

Из той темы
Цитата
а вот конец всегда меняется,в данном случае это 328 строка,
Код
Sub EndRow()
Dim EndRow As Long
Dim FoundCell As Range
   Set FoundCell = Columns("A").Find("10.03", , xlValues, xlWhole)
    If Not FoundCell Is Nothing Then
      EndRow = FoundCell.Row - 1
    End If
End Sub
Изменено: Kuzmich - 26 Май 2020 19:22:57
Копирование на отдельный лист данных из выгрузки 1С, относящиеся к конкретному пункту ()10.01)
 
А я еще вчера предлагал код, но ответ скрыли
Как сделать адрес диапозона переменным/динамичным, VBA
 
Цитата
Как сделать это динамичным?
Для вашего примера макрос в модуль листа cover
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("F2")) Is Nothing Then
    Application.EnableEvents = False
Dim iLastRow As Long
  With Worksheets("data")
    iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
   Select Case Target
     Case "вариант A"
       .Range("A1:A" & iLastRow).Copy Range("K1")
       .Range("D1:D" & iLastRow).Copy Range("L1")
       .Range("F1:F" & iLastRow).Copy Range("M1")
     Case "вариант B"
       .Range("D1:D" & iLastRow).Copy Range("K1")
       .Range("F1:F" & iLastRow).Copy Range("L1")
       .Range("C1:C" & iLastRow).Copy Range("M1")
   End Select
  End With
 End If
    Application.EnableEvents = True
End Sub

Срабатывает при изменении содержимого ячейки F2
Записать номера повторов с учетом двух условий.
 
Цитата
записать все номера повторов с одинаковым кодом и наименованием.
Код
Sub Kod_Naimenov()
Dim iLastRow As Long
Dim i As Long
Dim Kod As String
Dim FoundKod As Range
Dim FirstAdres As String
Dim Naimenov As String
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("E4:E" & iLastRow).ClearContents
  For i = 4 To iLastRow
    Kod = Cells(i, "B")
Set FoundKod = Columns(2).Find(Kod, Cells(i, "B"), xlValues, xlWhole)
    If Not FoundKod Is Nothing Then     'нашли код
        FirstAdres = FoundKod.Address   'адрес первого вхождения
          If FoundKod.Row = i Then
            Naimenov = Cells(FoundKod.Row, "C")
          End If
        Do
            Cells(i, "E") = Cells(i, "E") & FoundKod.Offset(, -1) & ", "
          Set FoundKod = Columns(2).FindNext(FoundKod)
        Loop While FoundKod.Address <> FirstAdres
          Cells(i, "E") = Left(Cells(i, "E"), Len(Cells(i, "E")) - 2)
    End If
  Next
End Sub

Изменено: Kuzmich - 26 Май 2020 15:42:17
Умножение чисел, разделенных знаком "/", Макрос
 
Цитата
умножал, а не складывал.
Код
Function ПроизвДРОБ(rn As Range) As String
    Dim a, S0&, S1&, Cel As Range
    S0 = 1: S1 = 1
    For Each Cel In rn
        If Cel <> "" Then
            a = Split(Cel, "/")
            S0 = S0 * Val(a(0))
            If UBound(a) = 1 Then S1 = S1 * Val(a(1))
        End If
    Next
    ПроизвДРОБ = S0 & "/" & S1
End Function
Копирование на определенный лист другой книги в зависимости от выбраного города
 
Нужно делать еще проверку: есть ли такой лист в другой книге
Выпадающий список с адресами, соответствующими выбранному номеру телефона
 
Цитата
Но у меня ни чего не выходит.
А вы пробовали изменить содержимое ячейки E4 ?
Выпадающий список с адресами, соответствующими выбранному номеру телефона
 
Посмотрите в файле
Изменено: Kuzmich - 24 Май 2020 16:49:31
Выпадающий список с адресами, соответствующими выбранному номеру телефона
 
Цитата
где модуль искать
Правой кнопкой мышки по ярлыку листа - Исходный текст выбрать лист Телефон и скопировать туда код
И не забудьте исправить формулу в G16
Выпадающий список с адресами, соответствующими выбранному номеру телефона
 
В модуль листа Телефон
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim FoundNomer As Range
Dim BD As Worksheet
Dim FAdr As String
  Set BD = ThisWorkbook.Worksheets("БД")
  If Not Intersect(Target, Range("E4")) Is Nothing Then
        Application.EnableEvents = False
    With BD
      Columns("AA").ClearContents
     Set FoundNomer = .Columns(1).Find(Target, , xlValues, xlWhole)
      If Not FoundNomer Is Nothing Then
       FAdr = FoundNomer.Address
       Do
         Cells(Cells(Rows.Count, "AA").End(xlUp).Row + 1, "AA") = FoundNomer.Offset(, 2)
         Set FoundNomer = .Columns(1).FindNext(FoundNomer)
       Loop While FoundNomer.Address <> FAdr
       With [E16].Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=" & Range(Range("AA2"), Range("AA2").End(xlDown)).Address & ""
        .IgnoreBlank = True
        .InCellDropdown = True
             .InputMessage = "выберите адрес!"
              .ShowInput = True
        .ShowError = True
    End With
      Else
          MsgBox "Нет такого номера в базе данных" & Target
          Range("E16") = ""
     End If
    End With
  End If
    Application.EnableEvents = True
End Sub
Изменено: Kuzmich - 24 Май 2020 17:17:58
Макрос разделения текста по столбцам с перемещением данных в один столбец
 
Цитата
выводило результаты только с данными, которые соответствуют "Критерию 2"
Код
Sub Email_Group_Kriteria2()
Dim FoundCell As Range
Dim FAdr As String
Dim arrGroup
Dim arrEmail
Dim i As Long
Dim n As Integer
Dim k As Integer
   k = 12
    Set FoundCell = Columns("A").Find("Критерий 2", , xlValues, xlWhole)
    If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
        arrGroup = Split(Cells(FoundCell.Row, "B"), ";")
        For i = 0 To UBound(arrGroup)
         arrEmail = Split(Cells(FoundCell.Row, "C"), ";")
          For n = 0 To UBound(arrEmail)
            Cells(k + n, "A") = arrGroup(i)
            Cells(k + n, "B") = arrEmail(n)
          Next
           k = k + n
        Next
        Set FoundCell = Columns("A").FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
    End If
End Sub

В другую книгу переделайте сами. Удачи!
Макрос разделения текста по столбцам с перемещением данных в один столбец
 
Цитата
как в файле на примере "Вид данных после отработки макросом
Код
Sub Email()
Dim arr
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
Dim k As Integer
   iLastRow = Range("A2").End(xlDown).Row
   k = 9
  For i = 3 To iLastRow
    arr = Split(Cells(i, "B"), ";")
    For n = 0 To UBound(arr)
      Cells(i + k + n, "A") = Cells(i, "A")
      Cells(i + k + n, "B") = arr(n)
    Next
    k = k + n - 1
  Next
End Sub
VBA. Наполнить таблицу в форме отчёта данными из "плоской" таблицы
 
Для тех у кого нет PQ и Fastreport.Desktop trial, короче для Excel2003
Макрос в стандартный модуль, запускать при активном листе 'данные'
Скрытый текст
Разложить существующие суммы страхования по КАСКО и ОСАГО на двенадцать месяцев
 
Цитата
разложить эту сумму
Код
Sub iRazlozhit()
Dim i As Long
Dim iLastRow As Long
Dim iLastCol As Integer
Dim j As Integer
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 iLastCol = Cells(2, Columns.Count).End(xlToLeft).Column
 Range(Cells(12, 2), Cells(iLastRow, iLastCol)).ClearContents
 iLastRow = Range("A3").End(xlDown).Row
    For i = 3 To iLastRow
      For j = 2 To iLastCol
        If Cells(i, j) <> "" Then
          Cells(i + 9, j).Resize(, 12) = Cells(i, j) / 12
        End If
      Next
    Next
End Sub
Подсчет по номиналам марок
 
А V*4 почему не попало в таблицу?
Поиск значения с двумя условиями: из выпадающего списка и фильтра, сложный впр с выпадающим списком
 
Посмотрите приемы https://www.planetaexcel.ru/techniques/1/38/
Поиск и удаление значений начинающихся на одинаковые символы из ячейки, Помогите написать формулу
 
Почему при номерах +79044933702, +79824133373 получить хотите 79044933702 +79824133373,
а при +79044906777, +79824133373 с запятой 79044906777, +79824133373
Почему не включается номер 88002223975 ?
У меня получилось макросом так
Код
Sub iMobil()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "\+?73452\d{6}"
   For i = 2 To iLastRow
     If .test(Cells(i, 1)) Then
       Set mo = .Execute(Cells(i, 1))
         For n = 0 To mo.Count - 1
           Cells(i, 2) = .Replace(Cells(i, 1), "")
         Next
         Cells(i, 2) = Replace(Cells(i, 2), ",", "")
     Else
        Cells(i, 2) = Cells(i, 1)
     End If
   Next
 End With
End Sub
Изменено: Kuzmich - 14 Май 2020 16:34:33
Преобразование текстовой записи в число с отбрасыванием лишнего
 
sokol92,
Спасибо за соображение. Удачи!
Преобразование текстовой записи в число с отбрасыванием лишнего
 
Цитата
не могу его осилить своим мозгом
UDF в стандартный модуль. В ячейку =iSec(ячейка с мин. и сек), например =iSec(A1)
Изменено: Kuzmich - 14 Май 2020 14:14:36
Поиск и удаление значений начинающихся на одинаковые символы из ячейки, Помогите написать формулу
 
Цитата
Красный цвет - это мои попытки выделить городские номера
Цитата
найти все городские номера т. е. начинающиеся на символы +7495
И где в вашем примере городские номера?
Преобразование текстовой записи в число с отбрасыванием лишнего
 
UDF
Код
Function iSec(cell$) As Double
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "\d+ ?(?=мин)"
     iSec = .Execute(cell)(0)
     .Pattern = "\d+ ?(?=сек)"
     iSec = iSec * 60 + .Execute(cell)(0)
 End With
End Function
Внесение начальных и конечных показаний электросчетчиков
 
Цитата
какой командой это сделано?
В модуле Листа2 написан макрос , срабатывающий на изменение содержимого ячейки F3
Внесение начальных и конечных показаний электросчетчиков
 
На Листе1 вносите показания счетчиков, на Листе2 из выпадающего списка
в ячейке F3 выбираете месяц и показания автоматически переносятся.
Стоимость квт/ч вносите вручную.
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 238 След.
Наверх