Добрый день! Подскажите, пожалуйста, как встроить статус бар в 2 готовых макроса, первый удаляет дубликаты в определенном столбце, а второй удаляет ненужную информацию по маске. Заранее спасибо за Ваше решение. Вот эти макросы:
| Код |
|---|
Sub DeleteDuble()
Dim Sh As Worksheet, URL As String, FilterMode As Boolean, rng As Range, rg As Range
Set C_Dubl = CreateObject("scripting.dictionary")
C_Dubl.CompareMode = 1
Set Sh = ThisWorkbook.Worksheets("Яндекс")
FilterMode = Sh.AutoFilter.FilterMode
If FilterMode Then
Sh.ShowAllData
End If
LastRow = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row
dx = Sh.Range("B1:C" & LastRow)
Set rng = Sh.Range("A1:D" & LastRow)
For n = 5 To UBound(dx)
URL = dx(n, 2)
If URL <> "" Then
If Not C_Dubl.Exists(URL) Then
C_Dubl.Item(URL) = URL
Else
If rg Is Nothing Then
Set rg = rng.Rows(n)
Else
Set rg = Union(rg, rng.Rows(n))
End If
End If
End If
Next
If Not rg Is Nothing Then
rg.Delete
LastRow = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row
Sh.Range("A5") = 1
Sh.Range("A6") = 2
Sh.Range("A5:A6").AutoFill Destination:=Sh.Range("A5").Resize(LastRow - 5, 1), Type:=xlFillDefault
End If
End Sub
|
| Код |
|---|
Sub DeleteMask()
Dim Sh As Worksheet, URL As String, FilterMode As Boolean, Sh1 As Worksheet, rng As Range, _
rg As Range, s As String
Set Sh = ThisWorkbook.Worksheets("слова исключения")
LastRow = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row
dd = Sh.Range("A1:B" & LastRow)
Set Sh1 = ThisWorkbook.Worksheets("исключения")
LastRow1 = Sh1.Cells(Sh1.Rows.Count, "A").End(xlUp).Row
Set Sh = ThisWorkbook.Worksheets("Яндекс")
FilterMode = Sh.AutoFilter.FilterMode
If FilterMode Then
Sh.ShowAllData
End If
LastRow = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row
dx = Sh.Range("B1:C" & LastRow)
Set rng = Sh.Range("A1:D" & LastRow)
For n = 5 To UBound(dx)
URL = dx(n, 2)
If URL <> "" Then
For i = 3 To UBound(dd)
s = dd(i, 1)
If s <> "" Then
If InStr(1, URL, s, vbTextCompare) > 0 Then
LastRow1 = LastRow1 + 1
Sh1.Cells(LastRow1, 1) = URL
If rg Is Nothing Then
Set rg = rng.Rows(n)
Else
Set rg = Union(rg, rng.Rows(n))
End If
Exit For
End If
End If
Next
End If
Next
If Not rg Is Nothing Then
rg.Delete
LastRow = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row
Sh.Range("A5") = 1
Sh.Range("A6") = 2
Sh.Range("A5:A6").AutoFill Destination:=Sh.Range("A5").Resize(LastRow - 5, 1), Type:=xlFillDefault
End If
End Sub
|
Ваши 700 000 строк для указанного метода - не проблема.