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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 214 След.
Преобразовать дату в виде текста в нормальную дату
 
Кросс 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+"
Извлечь из текста порядковые номера, которые начинаются с английской B, P, W и C
 
Atcdimon, написал
Цитата
а вот в моем exel все так же пустые ячейки
У вас там русские буквы С и Р
Код
Function iNomer(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .Pattern = "[BPWCСРВ]\d+"
   If .Test(cell) Then
     iNomer = .Execute(cell)(0)
   End If
 End With
End Function
Подтянуть значение в зависимости от даты
 
Цитата
неудобно пользоваться, когда все данные на одном листе..
Макрос в модуль листа ИТОГ
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("A2")) Is Nothing Then
    Application.EnableEvents = False
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim Dom As String
Dim FoundDom As Range
Dim Zamen As Worksheet
Dim Podpis As Worksheet
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("B6:E" & iLastRow).ClearContents
    Set Zamen = ThisWorkbook.Worksheets("Замещение")
    Set Podpis = ThisWorkbook.Worksheets("Подписанты")
  With Zamen
    iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
   For i = 3 To iLR
     If Target >= .Cells(i, "B") And Target <= .Cells(i, "C") Then
       Dom = .Cells(i, "A")
       Set FoundDom = Range("A6:A" & iLastRow).Find(Dom, , xlValues, xlWhole)
       If .Cells(i, "D") <> "" Then
          Cells(FoundDom.Row, "B") = .Cells(i, "D")
       Else
          Cells(FoundDom.Row, "D") = .Cells(i, "E")
       End If
     End If
   Next
  End With
     For i = 6 To iLastRow
       If Cells(i, "B") = "" Then Cells(i, "B") = Podpis.Cells(i - 4, "B")
       If Cells(i, "D") = "" Then Cells(i, "D") = Podpis.Cells(i - 4, "C")
     Next
  End If
    Application.EnableEvents = True
End Sub
VBA Передать в переменную часть текста из ячейки по условию
 
Код
AddressName = Application.Trim(Split(rRange, """")(2))
Подтянуть значение в зависимости от даты
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("A2")) Is Nothing Then
    Application.EnableEvents = False
Dim i As Long
Dim iLastRow As Long
Dim Dom As String
Dim FoundDom As Range
  Range("B6:B8").ClearContents
  iLastRow = Cells(Rows.Count, "L").End(xlUp).Row
   For i = 3 To iLastRow
     If Target >= Cells(i, "M") And Target <= Cells(i, "N") Then
       Dom = Cells(i, "L")
       Set FoundDom = Range("A6:A8").Find(Dom, , xlValues, xlWhole)
       Cells(FoundDom.Row, "B") = Cells(i, "O")
     End If
   Next
     For i = 6 To 8
       If Cells(i, "B") = "" Then Cells(i, "B") = Cells(i - 2, "G")
     Next
  End If
    Application.EnableEvents = True
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 214 След.
Наверх