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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 239 След.
Создание файла из 1С на основе шаблона
 
В начале процедуры вставьте Option Explicit
и запустите макрос в пошаговом режиме
Поиск части текста с разным количеством символов в ячейке и вывод в соседнюю
 
Код
Function iJpgPng(cell$)
 With CreateObject("VBScript.RegExp")
   .Pattern = "^.+(.jpg|.png)"
   iJpgPng = .Execute(cell)(0)
 End With
End Function
Суммирование динамического диапазона с пропусками, Суммирование динамичной колонки
 
Код
Sub Summa()
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "G").End(xlUp).Row
  Cells(iLastRow, "G").Formula = "=Sum(G6:G" & iLastRow - 1 & ")"
End Sub
Извлечь из текста только фамилию
 
Добавьте в макрос еще проверку на ЧП, как это сделано для ИП и ТОО
В строке ЧП   "Джумабаева" г.Шымкент затесался неразрывный пробел Chr(160),
поэтому попробуйте такую UDF
Код
Function FIO(cell As String) As String
Dim temp As String
 With CreateObject("VBScript.RegExp")
   .Pattern = "[""*«()]"
   temp = .Replace(cell, "")
     .Pattern = "^\s?([A-Za-zа-яА-ЯёЁ-]+)"
   If InStr(1, temp, "ИП") > 0 Then
     temp = Replace(temp, Chr(160), "")
     temp = WorksheetFunction.Trim(Split(temp, "ИП", 2)(1))
   ElseIf InStr(1, temp, "ТОО") > 0 Then
     temp = Replace(temp, Chr(160), "")
     temp = WorksheetFunction.Trim(Split(temp, "ТОО", 2)(1))
   ElseIf InStr(1, temp, "ЧП") > 0 Then
     temp = Replace(temp, Chr(160), "")
     temp = WorksheetFunction.Trim(Split(temp, "ЧП", 2)(1))
   End If
     FIO = .Execute(temp)(0)
 End With
End Function
Изменено: Kuzmich - 31 Май 2020 19:57:19
Извлечь из текста только фамилию
 
Так и не понял про ситуацию, если ИП или ТОО в конце текста?
А так попробуйте такую UDF
Код
Function FIO(cell As String) As String
Dim temp As String
 With CreateObject("VBScript.RegExp")
   .Pattern = "[""*«]"
   temp = .Replace(cell, "")
     .Pattern = "^\s?([A-Za-zа-яА-ЯёЁ]+)"
   If InStr(1, temp, "ИП") > 0 Then
     temp = Split(temp, "ИП ", 2)(1)
   ElseIf InStr(1, temp, "ТОО") > 0 Then
     temp = Split(temp, "ТОО ", 2)(1)
   End If
     FIO = .Execute(temp)(0)
 End With
End Function
Извлечь из текста только фамилию
 
Цитата
функция не корректно работают с некоторыми текстами.
Что выделять в отдельную ячейку, если ИП или ТОО в конце текста?
Что делать с ЧП?
Извлечь из текста только фамилию
 
Цитата
с помощью регулярного выражения извлечь фамилию, но не получается
Для данных из примера UDF
Код
Function FIO(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Pattern = "^(ИП|ТОО)?\s?([""а-яА-ЯёЁ]+)"
     FIO = .Execute(Replace(cell, """", ""))(0).SubMatches(1)
 End With
End Function
Обращение к ячейкам в цикле по листам
 
Цитата
чтобы он брал данные с нужного листа
Используйте конструкцию
Код
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/
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 239 След.
Наверх