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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 243 След.
Сводная таблица: не хватает ресурсов при формировании макросом, А если сводную делать вручную, то всё ОК
 
Цитата
Может, есть у кого-то код VBA для формирования сводной таблицы, чтоб работал нормально.
http://www.williamspublishing.com/Books/978-5-8459-1371-5.html  Глава 13
Нужно вытянуть определенный текст из строки
 
dixel, написал
Цитата
Вот алгоритм для каждого примера.
Если перефразировать, то:
брать текст до первого символа "-" с конца
брать текст до второго символа "-" с конца
брать текст до третьего символа "-" с конца
UDF, меняете j для ваших условий, например =iText(A2;3)
Код
Function iText(cell As String, j As Integer) As String
Dim mo As Object
Dim n As Integer
   With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "[^-]+"
    If .Test(cell) Then
      Set mo = .Execute(cell)
      For n = mo.Count - j To mo.Count - 1
        iText = iText & mo(n) & "-"
      Next
        iText = Left(iText, Len(iText) - 6)
    End If
   End With
End Function
Вывод части значения получаемого из списка в соседних ячейках, Необходимо вывести часть текстового значения получаемого из списка в соседних ячейках в зависимости от выбранного значения
 
Код
Sub XlebBaton()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
 Range("F5:U" & iLastRow).ClearContents
  For i = 5 To iLastRow
    If InStr(1, Cells(i, "E"), "Хлеб") > 0 Then
      Cells(i, "F").Resize(, 2 * Left(Split(Cells(i, "E"), "+ ")(1), 1)) = "Хлеб"
    End If
    If InStr(1, Cells(i, "E"), "Батон") > 0 Then
      Cells(i, "F").Resize(, 2 * Left(Split(Cells(i, "E"), "+ ")(1), 1)) = "Батон"
    End If
  Next
End Sub
Изменено: Kuzmich - 28 окт 2020 13:19:45
Вывод части значения получаемого из списка в соседних ячейках, Необходимо вывести часть текстового значения получаемого из списка в соседних ячейках в зависимости от выбранного значения
 
Юрий Семенов,
А почему в В11 4Батона, а в Е11 2Батона?
Поиск слова в ячейке и изменение цвета
 
Цитата
закрашивать несколько слов в ячейке, а не получается...
Попробуйте так
Код
Sub iTextColor()
Dim ptn
Dim i As Integer
Dim iLR As Long
Dim objMatch As Object
 With CreateObject("VBScript.RegExp")
   .Global = True
   .ignorecase = True
  iLR = Cells(Rows.Count, "D").End(xlUp).Row
      Columns("D:D").Font.ColorIndex = 0
      ptn = Array("цена", "этаж", "район")
    For i = 0 To UBound(ptn)
      .Pattern = ptn(i)
      If .test(Cells(7, "D")) Then
       Set objMatch = .Execute(Cells(7, "D"))(0)
           With Cells(7, "D").Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatch.Length).Font
              .ColorIndex = 3
           End With
      End If
   Next
 End With
End Sub
Поиск слова в ячейке и изменение цвета
 
Подправил макрос для вашего случая
Код
Sub iText()
Dim i As Long
Dim iLR As Long
Dim re As Object
Dim objMatches As Object
Dim objMatch As Object
  iLR = Cells(Rows.Count, "D").End(xlUp).Row
      Columns("D:D").Font.ColorIndex = 0
'  For i = 1 To iLR
      Set re = CreateObject("VBScript.RegExp")
         re.Global = True
         re.IgnoreCase = True
         re.Pattern = "цена"
        Set objMatches = re.Execute(Cells(7, "D"))
          If objMatches.Count <> 0 Then
             For j = 0 To objMatches.Count - 1
                Set objMatch = objMatches.Item(j)
                With Cells(7, "D").Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatch.Length).Font
                    .ColorIndex = 3
                End With
             Next
          End If
        Set re = Nothing
'    Next
End Sub
Поиск слова в ячейке и изменение цвета
 
Edgar-by,
Приложите пример в формате Excel
Поиск слова в ячейке и изменение цвета
 
Поиск вам в помощь https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=66010
Как разделить паспорт по разным ячейкам, на серию номер дата выдачи и кем выдан, Как разделить паспорт по разным ячейкам, на серию номер дата выдачи и кем выдан
 
boomgam,
Можно и все остальные параметры вытащить,
например
Код
Function iPasport(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "^.+\d{2}\s\d{2}"
     If .Test(cell) Then
       iPasport = .Execute(cell)(0)
     Else
       iPasport = ""
     End If
 End With
End Function

для серии
Код
Function iSer(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d{2}\s\d{2}"
     If .Test(cell) Then
       iSer = .Execute(cell)(0)
     Else
       iSer = ""
     End If
 End With
End Function
Изменено: Kuzmich - 21 окт 2020 20:01:03
Как разделить паспорт по разным ячейкам, на серию номер дата выдачи и кем выдан, Как разделить паспорт по разным ячейкам, на серию номер дата выдачи и кем выдан
 
UDF
Код
Function iВыдан(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d{2}\.\d{2}\.\d{4}.+$"
     If .Test(cell) Then
       iВыдан = Mid(.Execute(cell)(0), 12)
     Else
       iВыдан = ""
     End If
 End With
End Function
Как разделить паспорт по разным ячейкам, на серию номер дата выдачи и кем выдан, Как разделить паспорт по разным ячейкам, на серию номер дата выдачи и кем выдан
 
boomgam,
А что это за даты выдан 10.04.2109
выдан 22.04.2050
Вывести первое значение, дубликаты игнорировать
 
Цитата
Есть справочник из сумами, из нее берем сумму.
Код
Sub Сума()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B3:B" & iLastRow).ClearContents
  iLastRow = Cells(Rows.Count, "E").End(xlUp).Row
 For i = 3 To iLastRow
    Set FoundCell = Columns(1).Find(Cells(i, "E"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       FoundCell.Offset(, 1) = Cells(i, "F")
     End If
 Next
End Sub
Зеркально отобразить данные в ячейке
 
Цитата
опять Регулярные выражения напишет
Можно и так
Код
Function iRev(cell$)
 With CreateObject("VBScript.RegExp")
 Dim mo As Object
 Dim i As Integer
    .Global = True
    .Pattern = "[^,]+"
     Set mo = .Execute(cell)
     For i = mo.Count - 1 To 0 Step -1
       iRev = iRev & mo(i) & ","
     Next
     iRev = Left(iRev, Len(iRev) - 1)
 End With
End Function
Зеркально отобразить данные в ячейке
 
Цитата
Данные в ячейке цифры или через запятую 12,13,14,15
UDF
Код
Function iStrReverse(cell As String) As String
Dim temp
Dim i As Integer
  temp = Split(cell, ",")
  For i = UBound(temp) To 0 Step -1
    iStrReverse = iStrReverse & temp(i) & ","
  Next
    iStrReverse = Left(iStrReverse, Len(iStrReverse) - 1)
End Function
Отделить номер дома от улицы
 
UDF
Код
Function iHome(cell$)
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .Pattern = "\d+(/\d+)?[А-Г ]?(\s?СТР)?\.?$"
     iHome = .Execute(cell)(0)
 End With
End Function
Function iStreet(cell$)
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .Pattern = "\d+(/\d+)?[А-Г ]?(\s?СТР)?\.?$"
     iStreet = .Replace(cell, "")
 End With
End Function
Символы Юникода (не-кирилицы и не-латиницы) в шаблоне регулярных выражений, Добавление символов Юникода (не-кирилицы и не-латиницы) в шаблон регулярных выражений в коде VBA
 
Код
.Pattern = "[A-Z]{1}[a-z,\u00E8-\u00E9]+"
Как макросом пройтись по списку добавить каждому наименованию 30 строк и объединить по 30 ячеек
 
Добавьте в конец цикла строку
Код
    Range("C" & i + 1 & ":C" & i + 29).EntireRow.Hidden = True
Как макросом пройтись по списку добавить каждому наименованию 30 строк и объединить по 30 ячеек
 
Код
Sub Insert_30()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
  For i = iLastRow To 24 Step -1
    Rows(i + 1).Resize(29).Insert
    Range("C" & i & ":C" & i + 29).MergeCells = True
  Next
End Sub
Перенос объединенных ячеек между книгами
 
Mershik, написал
Цитата
а логика переноса есть
Я думаю, что надо объединенную ячейку С1 первого файла перенести в 7 ячеек С1:С7 второго файла
Макрос в первой книге
Код
Sub iCopy()
   Range("C1").Copy
   Workbooks("Файл2.xlsx").Worksheets("Лист1").Range("C1").Resize(Range("C1").MergeArea.Count).PasteSpecial xlPasteValues
End Sub
Изменено: Kuzmich - 13 окт 2020 16:23:38
макрос на смещение ячеек со словамии влево, так чтобы не оставались пустые ячейки, макрос на смещение ячеек влево, так чтобы не оставались пустые ячейки
 
Код
 Range(Cells(i, 2), Cells(i, iLastCol)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
макрос на смещение ячеек со словамии влево, так чтобы не оставались пустые ячейки, макрос на смещение ячеек влево, так чтобы не оставались пустые ячейки
 
Попробуйте заменить строку
Код
If iLastCol > 1 Then

на
Код
If WorksheetFunction.CountA(Range(Cells(i, 2), Cells(i, iLastCol))) < iLastCol - 1 Then
макрос на смещение ячеек со словамии влево, так чтобы не оставались пустые ячейки, макрос на смещение ячеек влево, так чтобы не оставались пустые ячейки
 
Екатерина,
Вы покажите в примере, где
Цитата
он перемещает слово на другую строку
макрос на смещение ячеек со словамии влево, так чтобы не оставались пустые ячейки, макрос на смещение ячеек влево, так чтобы не оставались пустые ячейки
 
Цитата
если в строке A5 три слова через пустую ячейку, он перемещает слово на другую строку
Покажите в примере
Макрос на добавления символов в ячейки столбца на определенную пощицию
 
Цитата
таких ячеек в столбце несколько тысяч......
Приведите десяток строк в примере
макрос на смещение ячеек со словамии влево, так чтобы не оставались пустые ячейки, макрос на смещение ячеек влево, так чтобы не оставались пустые ячейки
 
Код
Sub iDelEmpty()
Dim i As Long
Dim iLastRow As Long
Dim iLastCol As Integer
Dim j As Integer
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 For i = 1 To iLastRow
   iLastCol = Cells(i, Columns.Count).End(xlToLeft).Column
  If iLastCol > 1 Then
    Range(Cells(i, 2), Cells(i, iLastCol)).SpecialCells(xlCellTypeBlanks).Delete
   End If
 Next
End Sub
Изменено: Kuzmich - 11 окт 2020 17:35:07
макрос на смещение ячеек со словамии влево, так чтобы не оставались пустые ячейки, макрос на смещение ячеек влево, так чтобы не оставались пустые ячейки
 
Цитата
на данный момент макрос смещает слова влево
А где макрос?
Выделить из строки отдельные текстовые и числовые данные по разделителю "скобка"
 
Артем Ифанов,
Во второй строке нет пункта 6, как быть?
автозаполнение ячеек след столбца, автозаполнение ячеек след столбца
 
В модуль Лист2
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("A1:A1000")) Is Nothing Then
    Application.EnableEvents = False
Dim Oblast As Range
Dim i As Integer
    With Worksheets("Лист1")
      Set Oblast = .Columns(1).Find(Target, , xlValues, xlWhole)
        If Not Oblast Is Nothing Then
            i = Oblast.Row
          Do
            i = i - 1
          Loop While .Cells(i, "A").Interior.ColorIndex = -4142
        End If
        Target.Offset(, 1) = .Cells(i, "A")
    End With
 End If
    Application.EnableEvents = True
End Sub
Отображение списка в три колонки для печати, Отображение списка в три колонки для печати
 
Цитата
чтобы на одном листе была не одна таблица, а 3 таблицы
Создайте в книге Лист2 с такими же параметрами страницы, как и Лист1
Находясь на Лист1, запустите макрос
Код
Sub Spisok_3()
Dim iLastRow As Long
Dim iLR As Long
Dim iFirstRow As Long
Dim n As Integer
Dim k As Integer
Dim Shapka As Range
  n = 48    'число строк с данными на страницу
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
With Worksheets("Лист2")
  Range("A2:C2").Copy Range("D2").Resize(, 6)
  Set Shapka = Range("A2:I2")
    iFirstRow = 3
    .Cells.Clear
    iLR = 2
  Do
   Shapka.Copy .Cells(iLR, "A")
    For k = 0 To 2
      Range(Cells(iFirstRow + n * k, "A"), Cells(iFirstRow + n - 1 + n * k, "C")).Copy
      .Cells(iLR + 1, 3 * k + 1).PasteSpecial xlValues
    Next
     iLR = .Cells(.Rows.Count, "A").End(xlUp).Row + 2
     iFirstRow = iFirstRow + n * k
  Loop While iFirstRow < iLastRow
  .Activate
End With
End Sub
Преобразовать дату из ДД.ММ.ГГГГ в ГГГГ.ММ.ДД
 
Код
Просто потом оказывается, то у ТС дата в типа такого: "Начато 31.08.2020"

UDF
Код
Function iDate(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "(\d{1,2})\.(\d{1,2})\.(\d{2,4})"
     If .Test(cell) Then
       iDate = .Replace(cell, "$3.$2.$1.")
     Else
       iDate = ""
     End If
 End With
End Function
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 243 След.
Наверх