Страницы: 1
RSS
Удаление определенного текста из списка
 
Утро доброе.
Помогите с решением проблемы.

В столбце C4:C18 записан текст.
В ячейке E20 - указан текст, который содержится в этом списке (в одной из ячеек данного списка).

Как удалить данный текст (что находится в E20) из списка C4:C18, со сдвигом остальных элементов списка вверх (чтобы список оставался неразрывным) ?
 
Код
Sub Macro1()
Dim LastRow As Long, i As Long, x As Long, Arr(), Arr2, Krit
    Krit = Range("E20")
    LastRow = Cells(18, 3).End(xlUp).Row
    Arr = Range(Cells(4, 3), Cells(LastRow, 3)).Value
    ReDim Arr2(1 To UBound(Arr), 1 To 1)
    For i = 1 To UBound(Arr)
        If Arr(i, 1) <> Krit Then
            x = x + 1
            Arr2(x, 1) = Arr(i, 1)
        End If
    Next
    Range(Cells(4, 3), Cells(LastRow, 3)).ClearContents
    Range("C4").Resize(x, 1).Value = Arr2
End Sub
 
Юрий М, спасибо.

Скажите - вот в этом коде - почему выдается ошибка, если в списке - всего одна ячейка с текстом ?
Почему-то пишет Run-time error 13. Type mismatch.
И подсвечивает строку
Код
 Arr = Range(Cells(4, 3), Cells(LastRow, 3)).Value
 
Массив не может быть размерностью в один элемент.
 
Потому что массиву Arr() присваивается строка.

Arr = Range(Cells(4, 3), Cells(LastRow, 3)).Value              'LastRow = 4
Изменено: eeigor - 10.02.2019 19:48:31
 
eeigor, да не строка, а одна ячейка. Попытка создания массива размерностью (1 To 1, 1 To 1)
 
Да всё надо делать, работая непосредственно с диапазоном, без массивов. С обратным проходом из-за удаления ячеек, а не путем переписывания значений.
Изменено: eeigor - 10.02.2019 20:04:50
 
Опять неравильно. Каждой задаче свой подход.
 
eeigor, так как макрос изменить, чтобы он удалял ячейку из списка, в котором всего одна запись ?
 
Еще вариант:
Код
Sub aaa()
Dim arr(), arr1(), a&, b&
arr = [C4:C18].Value: ReDim arr1(1 To UBound(arr), 1 To 1)
For a = 1 To UBound(arr)
  If Len(arr(a, 1)) > 0 And arr(a, 1) <> [E20] Then b = b + 1: arr1(b, 1) = arr(a, 1)
Next
[C4].Resize(UBound(arr), 1) = arr1
End Sub
 
Anchoret, спасибо.
 
Цитата
eeigor написал:
Да всё надо делать, работая непосредственно с диапазоном, без массивов
Если диапазон небольшой, то можно работать и с листом, но при больших объёмах использование массива даст большой выигрыш в скорости.
А одну ячейку можно и без макроса проверить ))

Код
Sub Macro1()
Dim LastRow As Long, i As Long, x As Long, Arr(), Arr2, Krit
    Krit = Range("E20")
    LastRow = Cells(18, 3).End(xlUp).Row
    If LastRow > 4 Then
        Arr = Range(Cells(4, 3), Cells(LastRow, 3)).Value
        ReDim Arr2(1 To UBound(Arr), 1 To 1)
        For i = 1 To UBound(Arr)
            If Arr(i, 1) <> Krit Then
                x = x + 1
                Arr2(x, 1) = Arr(i, 1)
            End If
        Next
        Range(Cells(4, 3), Cells(LastRow, 3)).ClearContents
        Range("C4").Resize(x, 1).Value = Arr2
    Else
        If Cells(4, 3) = Krit Then Cells(4, 3) = ""
    End If
End Sub

 
Код
Option Explicit

Sub abc()
    Dim teS, r&
    With Range("C4:C18")
        Set teS = .Find(Range("E20").Value, .Cells(.Cells.Count), xlValues, xlWhole, xlByRows)
    End With
    If teS Is Nothing Then Exit Sub
    For r = teS.Row To Range("C4:C18").Rows.Count
        Cells(r, "C").Value = Cells(r + 1, "C").Value
    Next
End Sub
но как что-то под "с18" будет то ... :) ...
Изменено: ocet p - 10.02.2019 21:30:49
 
Цитата
ocet p написал:
Set teS = .Find(
Так не пойдет: нужно в цикле. Значений может быть >1.
Вариант от Anchoret идеальный. Лучше не напишешь.
Можно только укоротить диапазон [C4:C18] по высоте, убрав пустые снизу.
Изменено: eeigor - 10.02.2019 21:44:42
 
Цитата
eeigor написал:
Так не пойдет: нужно в цикле. Значений может быть >1
не нужно (у вас есть только один текст в вашей ячейке) ... :) ... но записи под таблицей (под "C18") мешают ... :)
Изменено: ocet p - 10.02.2019 21:48:21
 
Да, действительно.
 
… так и ещё один код … похож на код Anchoret ... :)
Код
Option Explicit

Sub def()
    Dim arr: arr = Range("C4:C18").Value
    Dim i&, poisk: poisk = Range("E20").Value
    For i = 1 To UBound(arr, 1)
        If arr(i, 1) = poisk Then Exit For
    Next
    If i > UBound(arr, 1) Then Exit Sub
    arr(i, 1) = ""
    For i = i To UBound(arr, 1) - 1
        arr(i, 1) = arr(i + 1, 1)
    Next
    Range("C4:C18").Value = arr: Erase arr
End Sub
 
Цитата
vikttur написал:
Массив не может быть размерностью в один элемент.
Вить, ты точно написал то, что хотел написать?
 
Расшифровка: нельзя на лету создать массив с размерностью по верткали 1 (один) и размерностью по горизонтали 1 (один). Ошибаюсь?
 
Это на лету, или нет?
Код
Sub Macro1()
    Dim LastRow As Long, i As Long, x As Long, arr, Arr2, Krit
    Krit = Range("E20")
    LastRow = Cells(18, 3).End(xlUp).Row
    arr = Range(Cells(4, 3), Cells(LastRow, 3)).Value
    If Not IsArray(arr) Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = Cells(4, 3).Value
    End If
    ReDim Arr2(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        If arr(i, 1) <> Krit Then
            x = x + 1
            Arr2(x, 1) = arr(i, 1)
        End If
    Next
    Range(Cells(4, 3), Cells(LastRow, 3)).ClearContents
    If x Then Range("C4").Resize(x, 1).Value = Arr2
End Sub
 
Нет. Подразумевалось
Код
Sub Macro2()
    Dim arr()
    arr = Cells(4, 3).Value

А у тебя в строке 5 - или переменная типа Variant, которая получила Range размером 1х1, или массив с размерностью >1
Страницы: 1
Наверх