Всем привет, уже создавала схожую тему, но дабы не апать, создаю другую. Просьба немного другая. В соседней моей теме, уже помогли, особенно 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
Надеюсь нормально объяснила Если надо, приложу пример.
Принцип тот же, пишем через пробел все, что должно остаться, а все остальное будет удалено
Код
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 Сегодня не было времени испробовать, вот сейчас села за пк, вроде работает:) Только почему-то не оставляет однозначные цифры. Двузначные удаляет, однозначные нет.
DANIKOLA, Добрый день Вот сейчас накидала цифр. Однозначные остаются так же. Буквы или цифры, не важно. Прикреплю пример. Может быть у меня что-то нет? Может быть версия excel не подходит?
Мария Гончарова написал: Только почему-то не оставляет однозначные цифры. Двузначные удаляет, однозначные нет.
Вводим через пробел что нужно оставить, т.е., не удалять, все остальное будет удалено.
Вот результат:
Все делал в Вашем файле, код не трогал. Я выделял первые три строчки, то что снизу осталось, я его просто не выделил. ----- Да, с цифрами работает не точно. Кто знал, что будут цифры.
написал: Мария Гончарова написал:Только почему-то не оставляет однозначные цифры. Двузначные удаляет, однозначные нет.
Я тут опечаталась. Только почему-то оставляет* однозначные цифры. Я там имела ввиду, если вводить двузначные цифры/буквы, остаются однозначные цифры/буквы. То есть, если ввести в это окошко "Введите искомый текст" что либо, кроме однозначных значений, то однозначные значения остаются почему-то. Но все равно, больше Вам спасибо за помощь
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