Страницы: 1
RSS
Удаление строк которые были добавлены, через запрос cvs файла, с фильтрацией, с помощью макроса
 
Подскажите, кто знает как удалить строки которые добавлены через запрос csv файла, плюс они добавляются как с фильтром и заголовком

такой макрос из-за выше перечисленного не работает
не может удалить строчки, как я понял, проверял без автофильтрации и запросов, работает, но мне это не подходит к сожалению

Файлы связаны должны быть через запрос, связь сломается если не ошибаюсь, это я о том, нужно ли менять макрос чисто под автофильтр или же нужно менять под связь и подключения
Код
Sub Удаление_строк()
    Dim sSubStr As String   'искомое слово или фраза
    Dim lCol As Long        'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long
    Dim avArr, lr As Long
    Dim arr
    Dim IsFind As Boolean
  
    lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "www.excel-vba.ru", 1))
    If lCol = 0 Then Exit Sub
    Application.ScreenUpdating = 0
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    'заносим в массив значения листа, в котором необходимо удалить строки
    arr = Cells(1, lCol).Resize(lLastRow).Value
    'Получаем с Лист2 значения, которые надо удалить в активном листе
    With Sheets("Лист2") 'Имя листа с диапазоном значений на удаление
        avArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
    'удаляем
    Dim rr As Range
    For li = 1 To lLastRow 'цикл с первой строки таблицы до конца
        IsFind = False
        For lr = 1 To UBound(avArr, 1) 'цикл по списку значений на удаление
            sSubStr = avArr(lr, 1)
            If InStr(1, arr(li, 1), sSubStr, 1) > 0 Then
                IsFind = True
            End If
            DoEvents
        Next lr
        'если значение таблицы не найдено в списке - удаляем строку
        If Not IsFind Then
            If rr Is Nothing Then
                Set rr = Cells(li, 1)
            Else
                Set rr = Union(rr, Cells(li, 1))
            End If
        End If
        DoEvents
    Next li
    If Not rr Is Nothing Then rr.EntireRow.Delete
    Application.ScreenUpdating = 1
End Sub
Изменено: Артем Тимченко - 11.08.2020 12:05:36
Страницы: 1
Наверх