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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 214 След.
поставить пробел между текстом и цифрой с определённой буквой, в конце теста иногда встречаются прикреплённые цифры, их нужно отделить
 
UDF
Код
Function iTowar(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "[A-Z]\d{1,2}(?=\s?[XХ])"
     iTowar = Left(cell, .Execute(cell)(0).FirstIndex + 1) & " " & Mid(cell, .Execute(cell)(0).FirstIndex + 2)
 End With
End Function
Изменено: Kuzmich - 14 Ноя 2019 18:16:09
Макрос: несколько условий, вставка в другой лист, исключая пустые ячейки, Помогите, пожалуйста, создать макрос с несколькими условиями
 
Цитата
пытаюсь во всем разобраться сама, но что-то пошло не так
В примере нет никаких макросов. Где ваши попытки?
На листе Общий приведите пример как должен выглядеть результат для дат в А2 и в А14.
Ячейки с определенным наименованием заполнять при соблюдении условий
 
Цитата
хотелось бы автоматизировать этот процесс
Код
Sub Nomer_TM()
Dim FoundModel As Range
Dim i As Long
Dim iLastRow As Long
  iLastRow = Range("A1").End(xlDown).Row
    Range("B3:C" & iLastRow).ClearContents
  For i = 3 To iLastRow
    Set FoundModel = Columns(6).Find(Split(Cells(i, 1), " ")(0), , xlValues, xlWhole)
    Cells(i, 3) = FoundModel.Offset(, 1)
    Cells(i, 2) = Columns(6).FindNext(FoundModel).Offset(, 1)
  Next
End Sub
Взять значения из одной ячейки и вставить их в другую после 4 символа
 
Код
Sub iPrice()
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim iPrice As String
   Range("C3:C" & iLastRow).ClearContents
 With CreateObject("VBScript.RegExp")
   .Pattern = "\d+\.\d+"
     For i = 3 To iLastRow
      iPrice = .Execute(Cells(i, 1))(0)
      Cells(i, 3) = Cells(i, 1)
      Cells(i, 3).Replace what:=iPrice, replacement:=Left(Cells(i, 2), Len(Cells(i, 2)) - 2)
     Next
 End With
End Sub
Преобразовать дату в виде текста в нормальную дату
 
Кросс http://www.excelworld.ru/forum/10-43389-1
Удаления текста справа после определенного знака
 
Макросои
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 1 To iLastRow
    Cells(i, 2) = Left(Cells(i, 1), InStrRev(Cells(i, 1), "/") - 1)
  Next
End Sub
Удалить часть текста (слова состоящие из заглавных букв)
 
Цитата
вроде работает, только пробелы съело между словами.
Код
Function iText(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
     .Pattern = "[A-Z\d\.]+\b"
   iText = Application.Trim(.Replace(cell, ""))
 End With
End Function

или
Код
Function iText_(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Pattern = "[A-Z][a-z]"
   iText_ = Mid(cell, .Execute(cell)(0).FirstIndex + 1)
 End With
End Function
Изменено: Kuzmich - 10 Ноя 2019 13:49:06
VBA Сбор данных из разных файлов на один лист, Копирование информации из нескольких файлов на один лист
 
Код
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Запрос пути (места) сохранения файла
 
У меня Excel 2003 и проверить ваш код я не могу
Запрос пути (места) сохранения файла
 
В сообщении #5 я такой цитаты не писал.
Запустите макрос в пошаговом режиме и проверьте его работу
Запрос пути (места) сохранения файла
 
Код
  
With Application.FileDialog(msoFileDialogSaveAs)
   If .Show = -1 Then   'кнопка Cancel не нажата
   .Execute
   '
   End If
End With
Объединение данных с удалением дублей с помощью макроса
 
О кроссе надо предупреждать http://www.excelworld.ru/forum/10-43370-1
Объединение данных с удалением дублей с помощью макроса
 
Цитата
есть ли способ как-то сделать
Код
Sub PerenosUniq()
Dim dicObj As Object
Dim i As Long
Dim FoundNomer As Range
Dim FAdr As String
Dim FDate As Date
Dim EDate As Date
Set dicObj = CreateObject("scripting.dictionary")
  For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
    dicObj.Item(CStr(Cells(i, "D"))) = dicObj.Item(CStr(Cells(i, "D"))) + Cells(i, "G") + Cells(i, "H")  'сумма в dicObj.items
  Next i
With Sheets("что должно быть")
 .Rows("2:" & Cells(Rows.Count, "D").End(xlUp).Row + 1).EntireRow.Delete
 .Range("D2").Resize(dicObj.Count) = Application.Transpose(dicObj.keys)
 .Range("G2").Resize(dicObj.Count) = Application.Transpose(dicObj.Items)
  For i = 2 To .Cells(.Rows.Count, "D").End(xlUp).Row
    Set FoundNomer = Columns(4).Find(.Cells(i, "D"), , xlValues, xlWhole)
    Range("A" & FoundNomer.Row & ":C" & FoundNomer.Row).Copy .Cells(i, "A")
    .Cells(i, "H") = Cells(FoundNomer.Row, "I")
    FAdr = FoundNomer.Address
      FDate = Cells(FoundNomer.Row, "E")
      EDate = Cells(FoundNomer.Row, "F")
      Do
        Set FoundNomer = Columns(4).FindNext(FoundNomer)
        If Cells(FoundNomer.Row, "E") < FDate Then FDate = Cells(FoundNomer.Row, "E")
        If Cells(FoundNomer.Row, "F") > EDate Then EDate = Cells(FoundNomer.Row, "F")
      Loop While FoundNomer.Address <> FAdr
        .Cells(i, "E") = FDate
        .Cells(i, "F") = EDate
  Next
End With
End Sub
Удалить часть текста (слова состоящие из заглавных букв)
 
UDF
Код
Function iText(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
   .Pattern = "[A-Z \d]+\b"
   iText = .Replace(cell, "")
 End With
End Function
Объединение данных с удалением дублей с помощью макроса
 
Макрос в стандартный модуль, запускать при активном листе "что есть"
Код
Sub PerenosUniq()
Dim dicObj As Object
Dim i As Long
Dim FoundNomer As Range
Set dicObj = CreateObject("scripting.dictionary")
  For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
    dicObj.Item(CStr(Cells(i, "D"))) = dicObj.Item(CStr(Cells(i, "D"))) + Cells(i, "G") + Cells(i, "H")  'сумма в dicObj.items
  Next i
With Sheets("что должно быть")
 .Rows("2:" & Cells(Rows.Count, "D").End(xlUp).Row).EntireRow.Delete
 .Range("D2").Resize(dicObj.Count) = Application.Transpose(dicObj.keys)
 .Range("G2").Resize(dicObj.Count) = Application.Transpose(dicObj.Items)
  For i = 2 To .Cells(.Rows.Count, "D").End(xlUp).Row
    Set FoundNomer = Columns(4).Find(.Cells(i, "D"), , xlValues, xlWhole)
    Range("A" & FoundNomer.Row & ":C" & FoundNomer.Row).Copy .Cells(i, "A")
    .Cells(i, "H") = Cells(FoundNomer.Row, "I")
  Next
End With
End Sub
Вывод определенных данных при выборе категории из списка
 
На листе1 в ячейке А1 выпадающий список. Макрос срабатывает на изменение значения в А1.
Макрос в модуль листа1
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("A1")) Is Nothing Then
   Application.EnableEvents = False
   Dim FoundCell As Range
     Range("B3:D6").ClearContents
   With Worksheets("Лист2")
        Set FoundCell = .Range("A16:A60").Find(Target, , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          .Range("B" & FoundCell.Row & ":D" & FoundCell.Row + 3).Copy Range("B3")
          Range("I1") = .Cells(FoundCell.Row, "H")
        End If
   End With
 End If
   Application.EnableEvents = True
End Sub
Вывод определенных данных при выборе категории из списка
 
gog909, Вы как-то придерживайтесь одной терминологииэ
У вас есть два листа Лист1 и Лист2.
На Листе2 в столбце А у вас Наименования (от 1 до 11). Это и есть ваши пункты?
Цитата
комментарий - "потому что завтра выходной"
Где это, на каком листе?
Цитата
при выборе значения из выпадающего списка
В какой ячейке этот список?
Вывод определенных данных при выборе категории из списка
 
Цитата
У каждого пункта "1", "2" и т.д. есть свой комментарии.
Что вы подразумеваете под комментариями?
Вывод определенных данных при выборе категории из списка
 
gog909, Вы хотите при выборе в А1 Листа1 какого-то наименования (от 1 до 11)
подтянуть с Листа2 значения по этому наименованию?
Разобрать строку на столбцы
 
Цитата
При добавлении в модуль, функция LastWord не появляется, в чем может быть проблема?
Функцию в стандартный модуль, появляется в категории: Определенные пользователем
в отдельную строку данные из ячейки содержащей несколько данных, В ячейке содержится несколько данных - нужно выделить и перенести только номера телефона
 
А пример выложить вы не собираетесь?
Извлечь из текста порядковые номера, которые начинаются с английской B, P, W и C
 
Код
Function iNomer(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .Pattern = "[BPWCСРВ]\d{3}[a-z]?"
   If .Test(cell) Then
     iNomer = .Execute(cell)(0)
     If Left(iNomer, 1) = "С" Then iNomer = "C" & Mid(iNomer, 2)
     If Left(iNomer, 1) = "Р" Then iNomer = "P" & Mid(iNomer, 2)
     If Left(iNomer, 1) = "В" Then iNomer = "B" & Mid(iNomer, 2)
     If Len(iNomer) = 4 Then iNomer = iNomer & " "
   End If
 End With
End Function
Извлечь из текста порядковые номера, которые начинаются с английской B, P, W и C
 
Добавьте условие, если длина 4 символа, то добавить пробел
Извлечь из текста порядковые номера, которые начинаются с английской B, P, W и C
 
Цитата
есть номера например как P013 и P013s,
Используйте паттерн
Код
.Pattern = "[BPWCСРВ]\d{3}[a-z]?"
Извлечь из текста порядковые номера, которые начинаются с английской B, P, W и C
 
достается одна из букв (B,C,P или W из англ. и  B,C,P из русск. алфавита и три цифры
Извлечь из текста порядковые номера, которые начинаются с английской B, P, W и C
 
Цитата
на выходе должны быть только латинские
Как я понял проблемы возникают только с тремя символами С, В и Р
Код
Function iNomer(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .Pattern = "[BPWCСРВ]\d+"
   If .Test(cell) Then
     iNomer = .Execute(cell)(0)
     If Left(iNomer, 1) = "С" Then iNomer = "C" & Mid(iNomer, 2)
     If Left(iNomer, 1) = "Р" Then iNomer = "P" & Mid(iNomer, 2)
     If Left(iNomer, 1) = "В" Then iNomer = "B" & Mid(iNomer, 2)
   End If
 End With
End Function
Распознавание форм бланков в excel
 
Я использую
ABBYY PDF Transformer + , выпуск 12.0.104.225, артикул 1132.27
       Позволяет в настройках выбор:
1. Игнорировать текст вне таблицы
2. Сохранять числовые данные в формате «цифры»
3. Сохранять колонтитулы
Распознавание форм бланков в excel
 
Цитата
какие существуют способы
Скачать бланки в формате Excel, например
https://www.audit-it.ru/forms/
Замена последних цифр в ячейке
 
А так
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Target, Columns(1)) Is Nothing Then
    Application.EnableEvents = False
Dim iCell As Double
Dim iDrob As Double
    iCell = Target.Value * 100
    iCell = Fix(iCell)
    iDrob = Application.InputBox("Введите три цифры замены", , Type:=1) / 1000
    iCell = (iCell + iDrob) / 100
    Target = iCell
  End If
    Application.EnableEvents = True
End Sub
Извлечь из текста порядковые номера, которые начинаются с английской B, P, W и C
 
Цитата
пишут  русскую 'В' и возникает проблема
Я включил русские буквы в паттерн
Код
.Pattern = "[BPWCСРВ]\d+"
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 214 След.
Наверх