Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
макрос удаление строк кроме определенных
 
#1
13.12.2018 08:13:06
Добрый день! Есть готовый макрос, в который нужно добавить несколько условий:
кроме строк со словом "яблоко" в определенном столбце, должны оставаться еще строки со словами "груша", "виноград", "банан" в этом же столбце.
Помогите пожалуйста, как их добавить в данный макрос?
Код
Dim sSubStr As String 'ячейка
    Dim lCol As Long 'столбец
    Dim lLastRow As Long, li As Long
    Dim arr
    Sheets("Выгрузка").Select
    sSubStr = "яблоко"
    lCol = "15"
    If lCol = 0 Then Exit Sub
 
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    arr = Cells(1, lCol).Resize(lLastRow).Value
 
    Application.ScreenUpdating = 0
    Dim pp As Range
    For li = 7 To lLastRow
        If CStr(arr(li, 1)) <> sSubStr Then
            If pp Is Nothing Then
                Set pp = Cells(li, 1)
            Else
                Set pp = Union(pp, Cells(li, 1))
            End If
        End If
    Next li
    If Not pp Is Nothing Then pp.EntireRow.Delete
    Application.ScreenUpdating = 1
    ActiveWorkbook.Save
    ActiveWindow.Close
Изменено: Евгения - 13.12.2018 08:49:36
 
 
 
#2
13.12.2018 08:37:10
Код
Dim sSubStr()  'массив условий
Dim li&, I&
Dim arr()
Dim pp As Range
Dim iTemp
Application.ScreenUpdating = 0
On Error Resume Next
sSubStr = Array("яблоко", "груша", "слива", "банан", "виноград")

With Sheets("Выгрузка")
    arr = .Cells(1, 15).Resize(.UsedRange.Row - 1 + .UsedRange.Rows.Count).Value
End With

With CreateObject("Scripting.Dictionary")
    For I = 0 To UBound(sSubStr)
        iTemp = .Item(sSubStr(I))
    Next
    For li = 1 To UBound(arr)
        If .Exists(CStr(arr(li, 1))) Then
            If pp Is Nothing Then
                Set pp = Sheets("Выгрузка").Cells(li + 6, 1)
            Else
                Set pp = Union(pp, Sheets("Выгрузка").Cells(li + 6, 1))
            End If
        End If
    Next li
End With

If Not pp Is Nothing Then pp.EntireRow.Delete
Application.ScreenUpdating = 1
ActiveWorkbook.Save
ActiveWindow.Close
Евгения,  оформите код макроса в Вашем сообщении так же как в моем. Ищите на панели инструментов кнопку '<...>'
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
13.12.2018 08:38:13
Евгения, Оформите код правильно , а то неудобно читать. Тут все зависит от того сколько значений, можно массив сделать с вашими данными и булеву
переменную по которой определять удаляем строку при определенном условии или нет. Можно через словарь сделать и с помощью метода exists проверять.
Изменено: Nordheim - 13.12.2018 08:42:01
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#4
13.12.2018 11:45:05
Sanja, что то не получается у меня, лишние не удаляются...
приложу файл с примером, все наглядней.
 
 
 
#5
13.12.2018 12:53:09
Код
Sub Удаление_строк()

Dim sSubStr()  'массив условий
Dim li&, I&
Dim arr()
Dim pp As Range
Dim iTemp
    Sheets("Выгрузка").Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Date, "dd.MM_Отчет_за ") & Format(Date - 1, "dd.mm") & ".xlsx"
Application.ScreenUpdating = 0
On Error Resume Next
sSubStr = Array("яблоко", "груша", "слива", "банан", "виноград")
 
With Sheets("Выгрузка")
    arr = .Cells(1, 15).Resize(.UsedRange.Row - 1 + .UsedRange.Rows.Count).Value
End With
 
With CreateObject("Scripting.Dictionary")
    For I = 0 To UBound(sSubStr)
        iTemp = .Item(sSubStr(I))
    Next
    For li = 1 To UBound(arr)
        If .Exists(CStr(arr(li, 1))) Then
            If pp Is Nothing Then
                Set pp = Sheets("Выгрузка").Cells(li, 1)
            Else
                Set pp = Union(pp, Sheets("Выгрузка").Cells(li, 1))
            End If
        End If
    Next li
End With
 
If Not pp Is Nothing Then pp.EntireRow.Delete
Application.ScreenUpdating = 1
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#6
13.12.2018 15:25:01
Sanja, спасибо большое! Очень помогли!
 
 
 
Страницы: 1
Наверх