Ребят, не всё так просто оказалось.. Кто подскажет, каким образом теперь мне удалить все ячейки, в которых встречается определенное слово??
Понятно надеюсь, что если я просто удалю столбец с этим словом, то останутся ещё другие ячейки где оно встречается по другим "ключевым словам". [moder]Начало тут[/moder]
Ребят, не всё так просто оказалось.. Кто подскажет, каким образом теперь мне удалить все ячейки, в которых встречается определенное слово??
Понятно надеюсь, что если я просто удалю столбец с этим словом, то останутся ещё другие ячейки где оно встречается по другим "ключевым словам". [moder]Начало тут[/moder]AdwordsDirect
Сообщение отредактировал Manyasha - Четверг, 16.03.2017, 12:29
А удалить вообще отовсюду нужно или в исходном списке (столбец A) не трогать, а удалить только из рейтинговых перечислений (начиная со столбца B). Удалить - это просто стереть значения, или еще подвинуть ячейки, чтоб не осталось пустот? Как определить удаляемое слово: оно будет в какой-то определенной ячейке или нужно сделать запрос пользователю, чтобы он его ввел?
А удалить вообще отовсюду нужно или в исходном списке (столбец A) не трогать, а удалить только из рейтинговых перечислений (начиная со столбца B). Удалить - это просто стереть значения, или еще подвинуть ячейки, чтоб не осталось пустот? Как определить удаляемое слово: оно будет в какой-то определенной ячейке или нужно сделать запрос пользователю, чтобы он его ввел?Perfect2You
Сообщение отредактировал Perfect2You - Вторник, 14.03.2017, 16:50
Не дождался ответа, сделал на предположениях. Просьба оценить: угадал ли, нет ли... [vba]
Код
Sub WordDelete() With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With Dim t: t = Timer Dim data, lR As Long, i As Long, j As Long, wD As String, dic As Object If (ActiveCell.Column = 1) Or (ActiveCell.Row > 1) Then Exit Sub wD = ActiveCell.Value If Len(wD) = 0 Then Exit Sub Set dic = CreateObject("scripting.dictionary") i = 2 Do While Len(Cells(1, i).Value) If LCase(Cells(1, i).Value) Like "*" & wD & "*" Then Columns(i).Delete Shift:=xlToLeft GoTo NXT End If lR = Cells(Rows.Count, i).End(xlUp).Row If lR = 3 Then If LCase(Cells(3, i).Value) Like "*" & wD & "*" Then Cells(3, i).ClearContents GoTo NX1 End If data = Cells(3, i).Resize(lR - 2).Value Cells(3, i).Resize(lR - 2).ClearContents dic.RemoveAll For j = 1 To UBound(data) If Not (LCase(data(j, 1)) Like "*" & wD & "*") Then dic(LCase(Trim(data(j, 1)))) = i End If Next j If dic.Count Then Cells(3, i).Resize(dic.Count) = Application.Transpose(dic.keys) ' If dic.Count Then ' Cells(3, i).Resize(dic.Count) = Application.Transpose(dic.keys) ' Else ' Columns(i).Delete Shift:=xlToLeft ' GoTo NXT ' End If NX1: i = i + 1 NXT: Loop
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With MsgBox "Готово!" End Sub
[/vba]
Исходные слова (столбец A) не трогает. Только выборные (столбец B и дальше).
Не дождался ответа, сделал на предположениях. Просьба оценить: угадал ли, нет ли... [vba]
Код
Sub WordDelete() With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With Dim t: t = Timer Dim data, lR As Long, i As Long, j As Long, wD As String, dic As Object If (ActiveCell.Column = 1) Or (ActiveCell.Row > 1) Then Exit Sub wD = ActiveCell.Value If Len(wD) = 0 Then Exit Sub Set dic = CreateObject("scripting.dictionary") i = 2 Do While Len(Cells(1, i).Value) If LCase(Cells(1, i).Value) Like "*" & wD & "*" Then Columns(i).Delete Shift:=xlToLeft GoTo NXT End If lR = Cells(Rows.Count, i).End(xlUp).Row If lR = 3 Then If LCase(Cells(3, i).Value) Like "*" & wD & "*" Then Cells(3, i).ClearContents GoTo NX1 End If data = Cells(3, i).Resize(lR - 2).Value Cells(3, i).Resize(lR - 2).ClearContents dic.RemoveAll For j = 1 To UBound(data) If Not (LCase(data(j, 1)) Like "*" & wD & "*") Then dic(LCase(Trim(data(j, 1)))) = i End If Next j If dic.Count Then Cells(3, i).Resize(dic.Count) = Application.Transpose(dic.keys) ' If dic.Count Then ' Cells(3, i).Resize(dic.Count) = Application.Transpose(dic.keys) ' Else ' Columns(i).Delete Shift:=xlToLeft ' GoTo NXT ' End If NX1: i = i + 1 NXT: Loop
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With MsgBox "Готово!" End Sub
[/vba]
Исходные слова (столбец A) не трогает. Только выборные (столбец B и дальше).Perfect2You
Насколько понимаю, требование модератора выполнено... В добавление к предыдущему посту с подпрограммой WordDelete. Для удаления ТОЛЬКО из первого столбца: [vba]
Код
Sub WordDelete1() With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With Dim t: t = Timer Dim data, lR As Long, i As Long, j As Long, wD As String, dic As Object If (ActiveCell.Column = 1) Or (ActiveCell.Row > 1) Then Exit Sub wD = ActiveCell.Value If Len(wD) = 0 Then Exit Sub Set dic = CreateObject("scripting.dictionary") lR = Cells(Rows.Count, 1).End(xlUp).Row If lR = 3 Then If LCase(Cells(3, 1).Value) Like "*" & wD & "*" Then Cells(3, 1).ClearContents Exit Sub End If data = Cells(3, 1).Resize(lR - 2).Value Cells(3, 1).Resize(lR - 2).ClearContents dic.RemoveAll For j = 1 To UBound(data) If Not (LCase(data(j, 1)) Like "*" & wD & "*") Then dic(LCase(Trim(data(j, 1)))) = i End If Next j If dic.Count Then Cells(3, 1).Resize(dic.Count) = Application.Transpose(dic.keys) If lR > dic.Count + 2 Then Rows((dic.Count + 3) & ":" & lR).Delete Shift:=xlUp
' If dic.Count Then ' Cells(3, i).Resize(dic.Count) = Application.Transpose(dic.keys) ' Else ' Columns(i).Delete Shift:=xlToLeft ' GoTo NXT ' End If
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With MsgBox "Готово!" End Sub
[/vba]
Для удаления отовсюду: [vba]
Код
Sub WordDeleteVse() If ActiveCell.Column = 1 Then WordDelete WordDelete1 Else WordDelete1 WordDelete End If End Sub
[/vba]
Насколько понимаю, требование модератора выполнено... В добавление к предыдущему посту с подпрограммой WordDelete. Для удаления ТОЛЬКО из первого столбца: [vba]
Код
Sub WordDelete1() With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With Dim t: t = Timer Dim data, lR As Long, i As Long, j As Long, wD As String, dic As Object If (ActiveCell.Column = 1) Or (ActiveCell.Row > 1) Then Exit Sub wD = ActiveCell.Value If Len(wD) = 0 Then Exit Sub Set dic = CreateObject("scripting.dictionary") lR = Cells(Rows.Count, 1).End(xlUp).Row If lR = 3 Then If LCase(Cells(3, 1).Value) Like "*" & wD & "*" Then Cells(3, 1).ClearContents Exit Sub End If data = Cells(3, 1).Resize(lR - 2).Value Cells(3, 1).Resize(lR - 2).ClearContents dic.RemoveAll For j = 1 To UBound(data) If Not (LCase(data(j, 1)) Like "*" & wD & "*") Then dic(LCase(Trim(data(j, 1)))) = i End If Next j If dic.Count Then Cells(3, 1).Resize(dic.Count) = Application.Transpose(dic.keys) If lR > dic.Count + 2 Then Rows((dic.Count + 3) & ":" & lR).Delete Shift:=xlUp
' If dic.Count Then ' Cells(3, i).Resize(dic.Count) = Application.Transpose(dic.keys) ' Else ' Columns(i).Delete Shift:=xlToLeft ' GoTo NXT ' End If
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With MsgBox "Готово!" End Sub
[/vba]
Для удаления отовсюду: [vba]
Код
Sub WordDeleteVse() If ActiveCell.Column = 1 Then WordDelete WordDelete1 Else WordDelete1 WordDelete End If End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
