Страницы: 1 2 След.
RSS
Удаление значений внутри ячейки по условию
 
Внутри ячеек есть наименование и размеры-число. Некоторые размеры перечеркнутым шрифтом. Частный случай когда размер-число перечеркнуто только "тиреЧисло" (если этот частный случай сильно усложняет, то без него). Необходимо удалить все размеры-число полностью не перечеркнутые.
Спасибо. Прошу исключительно добровольной макропомощи.
Изменено: Novichok55 - 25.05.2018 10:07:48
 
Цитата
Необходимо удалить все размеры-число полностью не перечеркнутые.
Результат в столбце В, вот только не получилось оставить формат с перечеркиванием
Код
Sub iNomer()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "[LMSX]+(/[LSX]+)?-\d{2}"
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("B1:B" & iLastRow).ClearContents
  For i = 1 To iLastRow
     Cells(i, 1).Copy Cells(i, 2)
     If .test(Cells(i, 1)) Then
       Set mo = .Execute(Cells(i, 1))
         For n = mo.Count - 1 To 0 Step -1
           If Cells(i, 1).Characters(mo(n).FirstIndex + 1, 1).Font.Strikethrough = True Or _
              Cells(i, 1).Characters(mo(n).FirstIndex + mo(n).Length, 1).Font.Strikethrough = True Then
           Else
              Cells(i, 2) = Replace(Cells(i, 2), mo(n), "")
           End If
         Next
    End If
   Next
 End With
End Sub
 
Большое спасибо. Работает в примере. На боевом материале тут же нашлось что-то. Сложно предположить, что же я не учел в примере, но если строку 6ть изменить, на то что в примере, то не срабатывает. Полчаса уже думаю, но пока не могу понять.
Кажется не работает на однозначных числах, вот что я не привел в примере :(
Преступным способом, взяв из другого макроса, чисто интуитивно ничего не изучая :( заменил \d{2} на (\d|,) начало работать с однозначными, но не удаляет второе число двузначных :(
Изменено: Novichok55 - 25.05.2018 21:11:29
 
Код
.Pattern = "[LMSX]+(/[LSX]+)?-\d{1,2}"
 
Kuzmich спасибо. Если я правильно понял, запятая тут как слово "до", от одно до двузначных. Чтоб предусмотреть трехзначные числа нужно написать
Код
.Pattern = "[LMSX]+(/[LSX]+)?-\d{1,3}"
?
В этой строке запись ...+(/[LSX]+)?... означает, что может быть, а может и не быть через дробь ещё что-то в обозначении размера? Именно знак вопроса дает такую пометку? Если бы ничеготочно больше не было, то достаточно было бы
Код
.Pattern = "[LMSX]+-\d{1,3}"
?
Изменено: Novichok55 - 25.05.2018 21:23:12
 
Да, все правильно вы поняли. Удачи!
 
Kuzmich подскажите пожалуйста. Mожно через это выражение ещё через пробел стоящие скобочки дописать как возможный вариант? Пробую
Код
.Pattern = "[LMSX]+(/[LSX]+)?-\d{1,3}+( (\d{1,3}))?"
ругается. Пробовал пробел вот так описать
Код
.Pattern = "[LMSX]+(/[LSX]+)?-\d{1,3}+(" "(\d{1,3}))?"
тоже ругается.
Это я пытаюсь через макрос, которым вы мне недавно помогали https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=104223&a... отделить размеры, включая скобки справа от размера, в отдельные ячейки, правда там форматирование не сохраняется.
Помогите пожалуйста, если нужно я создам новую тему.
Изменено: Novichok55 - 26.05.2018 19:43:27
 
Цитата
отделить размеры, включая скобки справа от размера
Попробуйте такой паттерн
Код
.Pattern = "[A-Z]+/?([A-Z]+)?-\d{1,3}( \(\d{1,3}\))?"
 
Kuzmich
спасибо работает. Просто чтоб иметь общее представление. Сохранив форматирование, т.е. чтоб в ячейки переезжало зачеркнутое зачеркнутым это уже космический пилотаж нужен?
 
Цитата
чтоб в ячейки переезжало зачеркнутое зачеркнутым это уже космический пилотаж нужен?
В какой-то из ваших тем SAS888 приводил вам код, где сохранялось зачеркивание
 
Kuzmichда вот к сожалению не сохраняется там зачёркивание, поэтому и все эти вопросы. Тема там по вычитанию как раз скобки справа минус число_размера, которое получается слева от этих скобок. Там полузачеркивание делается для этого частного случая, когда возле размера справа скобки и делается вычитание числа_в_скобках минус то которое у размера, в итоге зачеркнуто число_результат и тире, буква размера не зачеркнута. Поэтому в этой теме и было про полузачеркивание. Зачеркивание или полузачеркивание, нужно как метка для не удаления макросом этой темы.
Но как оказалось, если в той же ячейке стоит просто размер-число зачеркнутые (без скобок справа), то после процедуры над "соседями" оно теряет вообще свою зачеркнутость-метку_на_не_удаление и попадет по удаление.

В итоге появилась мысль. Вынести частные случаи (размер-число рядом справа скобки) временно в соседние ячейки строки. Проделать процедуру удаления не зачеркнутого как бы без них и до процедуры вычитания. По-простому, типа проделать вычитание потом не получится, т.к. размер-число не зачеркнуты (только число в скобках справа зачекнуто).

Вынести теперь я могу, но получается накладка. Ваш макрос результат выдает в столбец B и всё стирает. Нельзя ли сделать, чтоб он в том же A всё делал?
Второй вариант который вроде поможет, если вы захотите помогать, чтоб макрос не трогал случаи типа размер-число не зачеркнуты, но т.к. через пробел справа от них скобка он не попадает под удаление как не зачеркнутый. Это поизящнее, но наверно и на много сложнее, чем просто перенести результат макроса из столбца B.
Изменено: Novichok55 - 26.05.2018 21:22:46
 
Цитата
Но как оказалось, если в той же ячейке стоит просто размер-число зачеркнутые (без скобок справа), то после процедуры над "соседями" оно теряет вообще свою зачеркнутость-метку
В той теме https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=105056
зачеркнутые размеры оставались после действия макроса
 
Только когда строка не трогалась, не содержала "частных случаев" над которыми тот макрос работал.
Если же строка попадалась типа
зач-размерчсило(@) потом по соседству незач_размерчисло+скобки справа, то на выходе
незач-размерчисло(@) (вроде не обрабатывалось, но из-за соседства) потом по соседству полузачеркнутое размерчисло.

Как я там написал, в примере, к сожалению, я такого случая не привел и заметил это уже на реальном использовании.

Сделал, чтоб отрезало частные случаи в соседние ячейки начиная с столбца C, после этого провожу ваш макрос, он в столбец B, потом удаляю столбец A и всё на своих местах, костыли, но это не важно. Теперь вернуть частные случаи назад в ячейку...и проделать макрос SAS888, надеясь, что получится.

Всё провалилось :( при отрезании частных случаев в соседние ячейки (только их переносил слегка переделанным паттерном)
Код
.Pattern = "[A-Z]+/?([A-Z]+)?-\d{1,3}( \(\d{1,3}\))"
происходит та же бяка, что и с макросом SAS888, в затронутых ячейках (из тех в которых было, что вытягивать) с обычных зачеркнутых размер_число слетает форматирование.
Помогите пожалуйста добавкой в ваш макрос условия, которое я писал выше, чтоб если через пробел справа скобка с числом, то не зачеркнутый размер не удаляется.
Строка 6 и 9 в примере
Второй вариант, выносить в соседние ячейки ещё и эти самые с которых не кстати слетает форматирование (чтоб уже получится, исключительно то что на удаление в исходных ячейках осталось), но это уже такое, да и паттерн на выборку зачеркнутого для переноса в соседние ячейки, я вряд ли напишу.
Изменено: Novichok55 - 26.05.2018 23:33:52
 
Для вашего последнего примера попробуйте такой макрос (добавил в код от SAS888)
Код
Sub ReplSize()
    Dim i As Long
    Dim z As Range, s As String, a, b, x, y: Application.ScreenUpdating = False
    Set x = CreateObject("VBScript.RegExp"): x.Global = True: x.Pattern = "\d+ \(\d+\)"
    For Each z In Selection
        s = z.Value
        If x.Test(s) Then
            Set y = x.Execute(s)
            ReDim a(0 To y.Count - 1): b = a
            For i = 0 To y.Count - 1
                a(i) = InStr(s, y.Item(i))
                b(i) = Val(Split(s, "(")(1)) - Val(y.Item(i))
                s = Replace(s, y.Item(i), b(i))
            Next
            z.Value = s
            For i = LBound(a) To UBound(a)
                z.Characters(a(i), Len(b(i))).Font.Strikethrough = True
            Next
              a = Split(z, " ")
            For i = 0 To UBound(a)
             ReDim Preserve b(0 To UBound(a))
              If InStr(1, z.Offset(, -3), a(i)) > 0 Then
                b(i) = InStr(1, z.Offset(, -3), a(i))
                If z.Offset(, -3).Characters(b(i), 1).Font.Strikethrough = True Then
                  z.Characters(InStr(1, z, a(i)), Len(a(i))).Font.Strikethrough = True
                End If
              End If
            Next
        End If
    Next
End Sub
 
Ругаясь на
Код
If InStr(1, z.Offset(, -3), a(i)) > 0 Then
всё же проводит процедуру вычитания, но в строке 6 происходит, то от чего всё это, с m88 слетает зачеркивание и оно будет удалено вашим макросом, удаляющим всё не зачеркнутое.
 
Это макрос для последнего примера (сообщение #13)
Данные из столбца А переносите в D, выделяете данные в столбце D и
запускаете макрос
Изменено: Kuzmich - 26.05.2018 23:48:44
 
Именно в нем и проверяю. Выделяю в столбце A диапазон и запускаю.

Кажется, не слетело с того, с чего не нужно :) Спасибо. Щяс протестирую. Но если всё так, то данные к вашему макросу на удаление "всё не зачеркнутое" готовы.
Получается оно "посматривает" на столбец A, как там было, ого...
Изменено: Novichok55 - 27.05.2018 00:01:56
 
Цитата
Получается оно "посматривает" на столбец A, как там было, ого...
Да, исходный диапазон для этого и нужен
 
Попроверял как мог, в целом работает вся система. Но нашлось сочетание  которое не нравится макросу на удаление не_зачеркнутого, строка 4 в  примере.
Когда в названии следующего за зачернутым размером буква такая же как у предыдущего зачеркнутого (или последняя из букв) плюс у них число одинаковое, такое сочетание на рабочем материале очень часто бывает :(
 
Цитата
Novichok55 написал:
такое сочетание на рабочем материале очень часто бывает
И Вы его сразу показали?
 
:oops:  просто не догадываешься, что столько коварства вокруг :(
 
Цитата
Когда в названии следующего за зачернутым размером буква такая же как у предыдущего зачеркнутого (или последняя из букв) плюс у них число одинаковое
Поправил макрос. Частично зачеркнутые сделал полностью зачеркнутыми
Код
Sub iNomer()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim temp As String
Dim a, b()
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "[A-Z]+/?([A-Z]+)?-\d{1,3}( \(\d{1,3}\))?"
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("B1:B" & iLastRow).ClearContents
  For i = 1 To iLastRow
     Cells(i, 1).Copy Cells(i, 2)
     If .test(Cells(i, 1)) Then
       Set mo = .Execute(Cells(i, 1))
          temp = Cells(i, 1)
         For n = mo.Count - 1 To 0 Step -1
           If Cells(i, 1).Characters(mo(n).FirstIndex + 1, 1).Font.Strikethrough = True Or _
              Cells(i, 1).Characters(mo(n).FirstIndex + mo(n).Length, 1).Font.Strikethrough = True Then
           Else
              Mid(temp, mo(n).FirstIndex) = String(mo(n).Length + 1, " ")
           End If
         Next
           Cells(i, 2) = Application.Trim(temp)
             a = Split(Cells(i, 2), " ")
            For j = 0 To UBound(a)
             ReDim Preserve b(0 To UBound(a))
              If InStr(1, Cells(i, 1), a(j)) > 0 Then
                b(j) = InStr(1, Cells(i, 1), a(j))
                If Cells(i, 1).Characters(b(j), 1).Font.Strikethrough = True Or _
                   Cells(i, 1).Characters(b(j) + Len(a(j)) - 1, 1).Font.Strikethrough = True Then
                  Cells(i, 2).Characters(InStr(1, Cells(i, 2), a(j)), Len(a(j))).Font.Strikethrough = True
                End If
              End If
            Next
    End If
   Next
 End With
End Sub
 
Цитата
Novichok55 написал:
результат о котором мечтаю:
Код
Sub мяу()
    Dim i&, ii&
    Dim s$, ss$
    Dim objRegExp As Object, oMatches As Object
    Dim r As Range
    Dim col As Collection, x
    Set r = Selection
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True: objRegExp.IgnoreCase = False: objRegExp.MultiLine = False
    Application.ScreenUpdating = False
    For ii = r.Rows.Count To 1 Step -1
        If r(ii, 1).Font.Bold = True Then
            If IsEmpty(r(ii, 1).Offset(1)) Then r(ii, 1).EntireRow.Delete
        Else
            If r(ii, 1).Font.Strikethrough Then
            ElseIf r(ii, 1).Font.Strikethrough = False Then
                If Len(r(ii, 1)) Then r(ii, 1).EntireRow.Delete
            Else
                With r(ii, 1)
                    s = .Value
                    objRegExp.Pattern = " [A-Z/]+-\d+"
                    If objRegExp.test(s) Then
                        Set oMatches = objRegExp.Execute(s)
                        Set col = New Collection
                        For i = 0 To oMatches.Count - 1
                            If .Characters(oMatches(i).firstindex + 2, 1).Font.Strikethrough = False Then
                                col.Add oMatches(i).Value, oMatches(i).Value
                            End If
                        Next
                    End If
                    objRegExp.Pattern = "( [A-Z/]+)(-\d+) (\(\d+\))"
                    Set oMatches = objRegExp.Execute(s)
                    For i = 0 To oMatches.Count - 1
                        ss = oMatches(i).SubMatches(0) & -oMatches(i).SubMatches(1) - (Replace(Replace(oMatches(i).SubMatches(2), ")", ""), "(", ""))
                        On Error Resume Next
                        col.Remove ss
                        On Error GoTo 0
                        s = Replace(s, oMatches(i), ss)
                    Next
                    For Each x In col
                        s = Replace(s, x, "")
                    Next
                    .Value = Trim(s)
                    objRegExp.Pattern = " [A-Z/]+-\d+"
                    Set oMatches = objRegExp.Execute(s)
                    For i = 0 To oMatches.Count - 1
                        .Characters(oMatches(i).firstindex + 2, oMatches(i).Length - 1).Font.Strikethrough = True
                    Next
                End With

            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
Kuzmich
большое спасибо. Протестировал на немалом количестве материала, вроде всё отлично, ещё и полностью зачеркивает теперь всё.

RAN
приятно обескуражили, столько тем и страстей и вот он высший пилотаж. Всё в одном и работает. Огромное спасибо.
 
Kuzmich
RAN
извините пожалуйста, боюсь попросить, но вынужден. Нельзя ли, добавить, чтоб то что получено вычитанием, кроме того что оно щяс зачеркнуто, было ещё и курсивом.
Kuzmich то что было полузачеркнутым, щяс как бы аккуратнее, но не отличается от обычного зачеркнутого. Понял, что на практике мне бы такая помеченность курсивом для этих полученных вычитанием для понимания очень бы не помешала  :oops: Курсив намного нагляднее полузачекнутости.

Если только это не целое дело, честное слово, совершенно не представляю в рамках этих макросов как оно.
Сам попробовал в вашем Kuzmich под строкой
Код
Cells(i, 2).Characters(InStr(1, Cells(i, 2), a(j)), Len(a(j))).Font.Strikethrough = True
вставить
Код
Cells(i, 2).Characters(InStr(1, Cells(i, 2), a(j)), Len(a(j))).Font.Italic = True
оно все размеры, что обрабатывались и даже строки, что просто полностью были перечекнуты и не трогались вывело курсивом :( больше я не вижу, где там можно пристоиться.
Изменено: Novichok55 - 28.05.2018 19:26:31
 
Цитата
Novichok55 написал:
Нельзя ли, добавить
можно.
разрешаю добавить еще коллекцию.
 
RAN
извините, не очень вас понял, но к сожалению чисто интуитивное впечатление, что вы на меня обиделись, что я опять что-то придумываю? Мне как бы действительно неплохо бы знать сразу, это просто изначально зачеркнутая или из вычитания позиция. В примере сразу про это не сказал, но всего сразу ну никак, это вызревает в процессе, когда уже есть то что в примере хотел :(
В сообщении максимально пытался дать понять, что только если будет желание и это не целое дело.
Изменено: Novichok55 - 28.05.2018 20:11:23
 
Я не обиделся, а подсказал путь решения проблемы.
 
Не соображу, извините, о какой коллекции речь?
 
RAN
спасибо. Я уже понял, буду стараться раз вы считает что я и сам смогу, надеюсь получится выстроить правильно конструктор вашего макроса, чтоб нужной мне части присвоить ещё и italic :) или наоборот отделить её от той которая просто зачеркнута. Это вставить под то что уже есть
Код
.Characters(oMatches(i).firstindex + 2, oMatches(i).Length - 1).Font.Italic = True
я конечно же попробовал, результат понятно не тот, но и не совсем как макросе Kuzmich.
Изменено: Novichok55 - 28.05.2018 21:47:21
Страницы: 1 2 След.
Наверх