Страницы: 1
RSS
Макрос для нахождения значений и удаление соседних значений
 
Всем привет, уже создавала схожую тему, но дабы не апать, создаю другую. Просьба немного другая. В соседней моей теме, уже помогли, особенно DANIKOLA. За что ему, больше спасибо.
Он написало код, для поиска значений и удалений их со сдвигом влево. Так сказать, упростил мне жизнь:) Надоело, каждый раз через найти и заливку всё делать. Может ли кто нибудь изменить его код так, чтобы так же искать значения, но при этом удалять не их, а те, которые не искались, то есть те, которые остались(соседние). И так же со сдвигом влево. Вот его код:
Код
Sub DeleteCellByVal()
    Dim r As Range, s As String, sDefaultText As String, sArr As Variant, i As Byte
    sDefaultText = GetSetting("DeleteCellByValue", "Folder1", "DefaultString")
    s = InputBox("Введите искомый текст", "Удаление текста", sDefaultText)
    s = Application.WorksheetFunction.Trim(s)
    If s = "" Then Exit Sub
    SaveSetting "DeleteCellByValue", "Folder1", "DefaultString", s
    If TypeName(Selection) = "Range" Then
        Set r = Selection
        If r.Cells.Count = 1 Then
            MsgBox "Выделенна только одна ячейка!", vbQuestion, "Вы серьёзно?"
            Exit Sub
        End If
    Else
        Exit Sub
    End If
    Application.ScreenUpdating = False
    If InStr(1, s, " ") > 0 Then
        sArr = Split(s, " ")
        For i = LBound(sArr) To UBound(sArr)
            r.Replace sArr(i), "", 1
        Next i
    Else
        r.Replace s, "", 1
    End If
        r.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End Sub
Надеюсь нормально объяснила :oops:  Если надо, приложу пример.
 
Сестра, файл... (В нем что есть и что надо получить)
Изменено: New - 25.11.2021 22:41:34
 
Принцип тот же, пишем через пробел все, что должно остаться, а все остальное будет удалено
Код
Sub InvertedRemoving()
    Dim Arr As Variant, s As String, i As Integer, j As Integer
    If TypeName(Selection) <> "Range" Then Exit Sub
    Arr = Selection
    s = InputBox("Введите искомый текст", "Инвертное удаление текста")
    If s = "" Then Exit Sub
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        For j = LBound(Arr, 2) To UBound(Arr, 2)
            If InStr(1, s, Arr(i, j), vbTextCompare) = 0 Then
                Arr(i, j) = ""
            End If
        Next j
    Next i
    Selection = Arr
    Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End Sub

Макрос чувствителен к регистру, если нужно это можно изменить добавив в строку If InStr(1, s, Arr(i, j), vbTextCompare)...
------
Цитата
Мария Гончарова написал:
Двузначные удаляет, однозначные нет.  
Проверял у себя, вроди все работает. Вы ведь в файле-примере нормальных данных не предоставили, а только "a b c d h f...", вот и результат.

P.S. Может у Вас просто кривоватые данные, возможно в ячейках с однозначными числами присутствует еще какой-нибудь пробел или еще чего...
Изменено: DANIKOLA - 26.11.2021 21:22:17 (Добавлен ответ)
 
Цитата
DANIKOLA: это можно изменить добавив
переменную и небольшой комментарий прямо внутри кода
Код
Dim comp&
'comp=1 'раскомментировать для поиска без учёта регистра
'…
InStr(1, s, Arr(i, j), comp) = 0
это просто вариант - никакой критики  :)
Изменено: Jack Famous - 26.11.2021 08:46:56
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Всем спасибо, как всегда, отдельный поклон DANIKOLA
Сегодня не было времени испробовать, вот сейчас села за пк, вроде работает:) Только почему-то не оставляет однозначные цифры. Двузначные удаляет, однозначные нет. :(  
 
DANIKOLA, Добрый день :)  Вот сейчас накидала цифр. Однозначные остаются так же. Буквы или цифры, не важно. Прикреплю пример. Может быть у меня что-то нет? Может быть версия excel не подходит?
Изменено: Мария Гончарова - 27.11.2021 16:44:40
 
Цитата
Мария Гончарова написал:
Только почему-то не оставляет однозначные цифры. Двузначные удаляет, однозначные нет.
Вводим через пробел что нужно оставить, т.е., не удалять, все остальное будет удалено.

Вот результат:

Все делал в Вашем файле, код не трогал.
Я выделял первые три строчки, то что снизу осталось, я его просто не выделил.
-----
Да, с цифрами работает не точно. Кто знал, что будут цифры.
Изменено: DANIKOLA - 27.11.2021 20:10:51
 
Цитата
написал:
Мария Гончарова  написал:Только почему-то не оставляет однозначные цифры. Двузначные удаляет, однозначные нет.
Я тут опечаталась. Только почему-то оставляет* однозначные цифры.
Я там имела ввиду, если вводить двузначные цифры/буквы, остаются однозначные цифры/буквы. То есть, если ввести в это окошко "Введите искомый текст" что либо, кроме однозначных значений, то однозначные значения остаются почему-то.
Но все равно, больше Вам спасибо за помощь :)  
 
Цитата
Мария Гончарова написал:
двузначные цифры
Таких не бывает )
 
Вот этот код попробуйте:
Код
Sub InvertedRemoving()
    Dim Arr As Variant, s As String, i As Integer, j As Integer, b As Boolean, strArr, itemArr
    If TypeName(Selection) <> "Range" Then Exit Sub
    Arr = Selection
    s = InputBox("Введите искомый текст(через пробел, если несколько!)", "Инвертное удаление текста")
    s = Application.WorksheetFunction.Trim(s)
    If s = "" Then Exit Sub
    If InStr(1, s, " ") > 0 Then
        strArr = Split(s, " ")
            For i = LBound(Arr, 1) To UBound(Arr, 1)
                For j = LBound(Arr, 2) To UBound(Arr, 2)
                    For Each itemArr In strArr
                        If CStr(Arr(i, j)) = itemArr Then
                            b = True
                            Exit For
                        End If
                    Next itemArr
                    If b = False Then
                        Arr(i, j) = ""
                    End If
                    b = False
                Next j
            Next i
    Else
            For i = LBound(Arr, 1) To UBound(Arr, 1)
                For j = LBound(Arr, 2) To UBound(Arr, 2)
                        If CStr(Arr(i, j)) <> s Then
                            Arr(i, j) = ""
                        End If
                Next j
            Next i
    End If
    Selection = Arr
    Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End Sub
 
DANIKOLA,
Попробовала, все круто работает, как и надо:) Спасибо большущее :*  Сейчас вот ещё раз пригодился.
Изменено: Мария Гончарова - 04.12.2021 16:32:29
Страницы: 1
Наверх