Код |
---|
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.