Нужен макрос, который позволит удалить ВСЮ строку, если в ячейке 10го столбца будут найдены такие данные. Прайс состовляет 100 000 строк, желательно чтобы он быстро отработал. Очень нужна помощь. Буду премного благодарен.
P.S> Есть такой скрипт:
[vba]
Код
Sub б_Удаление_строки_с_пустой_ячейкой_категорий8() On Error Resume Next ActiveSheet.UsedRange.Columns(8).SpecialCells(4).EntireRow.Delete End Sub
[/vba]
Но он удаляет строки где найдены пустые ячейки в столбце 8. Может его возможно переделать, под мою задачу?
Есть прайс лист, местами в ячейке (10го столбца) попадаются такие значения:
Нужен макрос, который позволит удалить ВСЮ строку, если в ячейке 10го столбца будут найдены такие данные. Прайс состовляет 100 000 строк, желательно чтобы он быстро отработал. Очень нужна помощь. Буду премного благодарен.
P.S> Есть такой скрипт:
[vba]
Код
Sub б_Удаление_строки_с_пустой_ячейкой_категорий8() On Error Resume Next ActiveSheet.UsedRange.Columns(8).SpecialCells(4).EntireRow.Delete End Sub
[/vba]
Но он удаляет строки где найдены пустые ячейки в столбце 8. Может его возможно переделать, под мою задачу?wwizard
wwizard, а вы уверены, что эти строки нужно удалить? а если их преобразовать в читабельный вид? [vba]
Код
Sub gg() Dim cell As Range Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then With CreateObject("scriptcontrol") .Language = "JScript" Do While Not cell Is Nothing cell.Value = .Eval("unescape(""" & cell & """)") Set cell = Columns(10).FindNext(cell) Loop End With End If End Sub
[/vba]
wwizard, а вы уверены, что эти строки нужно удалить? а если их преобразовать в читабельный вид? [vba]
Код
Sub gg() Dim cell As Range Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then With CreateObject("scriptcontrol") .Language = "JScript" Do While Not cell Is Nothing cell.Value = .Eval("unescape(""" & cell & """)") Set cell = Columns(10).FindNext(cell) Loop End With End If End Sub
wwizard, добрый день,протестируйте макрос на листе Лист2,кнопки test и повтор
[vba]
Код
Sub test() Dim z, i&: z = Range("J1:J" & Range("J" & Rows.Count).End(xlUp).Row).Value With CreateObject("VBScript.RegExp"): .Pattern = "\u\d+" For i = UBound(z) To 1 Step -1: If .test(z(i, 1)) Then Rows(i).Delete Next End With End Sub
[/vba]
wwizard, добрый день,протестируйте макрос на листе Лист2,кнопки test и повтор
[vba]
Код
Sub test() Dim z, i&: z = Range("J1:J" & Range("J" & Rows.Count).End(xlUp).Row).Value With CreateObject("VBScript.RegExp"): .Pattern = "\u\d+" For i = UBound(z) To 1 Step -1: If .test(z(i, 1)) Then Rows(i).Delete Next End With End Sub
[offtop] wwizard, не поленилась и пролистала последние 20 Ваших тем. Ни в одной из них Вы не отписались по предложенным решениям, подошло или нет. Я подсмотрела, что плюсики Вы всем ставите - это здорово, но в самих темах, пожалуйста, отписывайтесь тоже, чтобы все видели.[/offtop]
[offtop] wwizard, не поленилась и пролистала последние 20 Ваших тем. Ни в одной из них Вы не отписались по предложенным решениям, подошло или нет. Я подсмотрела, что плюсики Вы всем ставите - это здорово, но в самих темах, пожалуйста, отписывайтесь тоже, чтобы все видели.[/offtop]Manyasha
добавил на всякий случай 2 кнопки 1я - для читабельности, 2я для удаления [vba]
Код
Sub gg() Dim cell As Range Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then With CreateObject("scriptcontrol") .Language = "JScript" Do While Not cell Is Nothing cell.Value = .Eval("unescape(""" & cell & """)") Set cell = Columns(10).FindNext(cell) Loop End With End If End Sub Sub ggg() Dim cell As Range, rng As Range, addr$ Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then addr = cell.Address Do If rng Is Nothing Then Set rng = cell _ Else Set rng = Union(rng, cell) Set cell = Columns(10).FindNext(cell) Loop While cell.Address <> addr If Not rng Is Nothing Then rng.EntireRow.Delete End If End Sub
[/vba]
добавил на всякий случай 2 кнопки 1я - для читабельности, 2я для удаления [vba]
Код
Sub gg() Dim cell As Range Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then With CreateObject("scriptcontrol") .Language = "JScript" Do While Not cell Is Nothing cell.Value = .Eval("unescape(""" & cell & """)") Set cell = Columns(10).FindNext(cell) Loop End With End If End Sub Sub ggg() Dim cell As Range, rng As Range, addr$ Set cell = Columns(10).Find("\u", , xlValues, xlPart) If Not cell Is Nothing Then addr = cell.Address Do If rng Is Nothing Then Set rng = cell _ Else Set rng = Union(rng, cell) Set cell = Columns(10).FindNext(cell) Loop While cell.Address <> addr If Not rng Is Nothing Then rng.EntireRow.Delete End If End Sub