Страницы: 1
RSS
Макрос: удаление строк на другом листе по условию (без совпадения - удалить)
 
На первом листе столбец А (product_id) - id товаров по которым необходимо найти совпадения на листах 2 и 3 ( так же по столбцу А).
Товары по которым не было совпадений на листах 2 и 3, относительно 1 листа - удалить (удалить на 2 и 3 листах).
Спасибо!
 
mr.Stone, it looks like TR (technical requirement)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Код
Option Explicit
Dim wbOut As Workbook
Dim dicID As Object
    
Sub DelRows()
    Dim wbFrom As Workbook
    Set wbFrom = ActiveWorkbook
    
    Set dicID = GetDicID(wbFrom.Sheets("Products"))
    
    Set wbOut = Workbooks.Add(1)
    
    Dim sheetName As Variant
    Dim sh As Worksheet
    For Each sheetName In Array("ProductOptions", "ProductOptionValues")
        On Error Resume Next
        Set sh = wbFrom.Sheets(sheetName)
        On Error GoTo 0
        If Not sh Is Nothing Then
            CopySheet sh
            Set sh = Nothing
        End If
    Next
    
    FinalizeWbOut wbOut
End Sub

Private Sub FinalizeWbOut(wbOut As Workbook)
    With wbOut
        If .Sheets.Count > 1 Then
            Application.DisplayAlerts = False
            .Sheets(1).Delete
            Application.DisplayAlerts = True
        End If
        
        .Saved = True
    End With
End Sub

Private Sub CopySheet(sh As Worksheet)
    sh.Copy After:=wbOut.Sheets(wbOut.Sheets.Count)
    
    With ActiveSheet
        Dim arr As Variant
        Dim orr As Variant
        Dim rUsedRange As Range
        Set rUsedRange = .UsedRange
        arr = rUsedRange
        ReDim orr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        
        Dim x As Integer
        Dim y As Long
        Dim u As Long
        For y = 1 To UBound(arr, 1)
            If dicID.Exists(arr(y, 1)) Then
                u = u + 1
                For x = 1 To UBound(arr, 2)
                    orr(u, x) = arr(y, x)
                Next
            End If
        Next
        Erase arr
            
        .Cells.ClearContents
        rUsedRange = orr
    End With
End Sub

Private Function GetDicID(sh) As Object
    Dim arr As Variant
    With sh
        arr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 2))
    End With
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 1 To UBound(arr, 1)
        dic.Item(arr(y, 1)) = 0
    Next
    
    Set GetDicID = dic
End Function
I suppose I didn't screwed plans about realization of that TR.
 
Код
Sub ProdDel()
    Dim sh As Worksheet, r As Long, ShForDel
    ShForDel = Array("ProductOptions", "ProductOptionValues")
    For Each sh In ThisWorkbook.Sheets
        If Not IsError(Application.Match(sh.Name, ShForDel, 0)) Then
            For r = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row To 1 Step -1
                If IsError(Application.Match(sh.Cells(r, "A"), Sheets("Products").Columns("A"), 0)) Then
                    sh.Rows(r).Delete
                End If
            Next r
        End If
    Next sh
    MsgBox "done"
End Sub
 
Спасибо большое!
Страницы: 1
Наверх