Страницы: 1 2 След.
RSS
Нужен макрос для удаления строк
 
Добрый день уважаемые форумчане!  
Помогите пожалуйста с макросом для удаления строк. На форуме нашел несколько макросов, но для себя приспособить их увы, не смог. Пример в файле.  
Заранее благодарю всех откликнувшихся.
 
может это поможет: :)  
 
 
Удаление пустых строк_1  
Selection.SpecialCells(xlCellTypeBlanks).Select  
Selection.Delete Shift:=xlUp  
Удаление пустых строк_2  
Sub DeleteEmptyStrings()  
  Dim intLastRow As Integer  ' Номер последней используемой строки  
  Dim intRow As Integer      ' Номер проверяемой строки  
 
  ' Получение номера последней используемой строки  
  intLastRow = Worksheets(ActiveSheet.Index).UsedRange.Row + _  
   Worksheets(ActiveSheet.Index).UsedRange.Rows.Count - 1  
  ' Счетчик устанавливается на используемую первую строку  
  intRow = Worksheets(ActiveSheet.Index).UsedRange.Row  
  ' Удаление пустых строк  
  Do While intRow <= intLastRow  
     If ActiveSheet.Rows(intRow).Text = "" Then  
        ' Удаление строки  
        ActiveSheet.Rows(intRow).Delete  
        ' Данные сдвинулись вверх, поэтому номер последней _  
         строки уменьшился, а текущей - не изменился  
        intLastRow = intLastRow - 1  
     Else  
        ' Текущая строка заполнена - переходим к следующей  
        intRow = intRow + 1  
     End If  
  Loop  
End Sub  
Удаление пустых строк_3  
Sub DeleteEmptyStrings1()  
  Dim intRow As Integer  
  Dim intLastRow As Integer  
 
  ' Получение номера последней используемой строки  
  intLastRow = ActiveSheet.UsedRange.Row + _  
   ActiveSheet.UsedRange.Rows.Count - 1  
 
  ' Удаление пустых строк  
  For intRow = intLastRow To 1 Step -1  
     If ActiveSheet.Rows(intRow).Text = "" Then  
        ActiveSheet.Rows(intRow).Delete  
     End If  
  Next intRow  
End Sub  
Удаление строки по условию  
Sub Макрос1()  
Dim iRange As Range  
Dim TextToFindArray As Variant  
Dim i As Long  
 
TextToFindArray = Array("Toyota", "ВАЗ")  
With Application  
.ScreenUpdating = False  
.Calculation = xlCalculationManual  
For i = 0 To 1  
With ActiveSheet.Cells  
Set iRange = .Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)  
If Not iRange Is Nothing Then  
Do  
iRange.EntireRow.Delete  
Set iRange = .Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)  
Loop While Not iRange Is Nothing  
End If  
End With  
Next i  
.Calculation = xlCalculationAutomatic  
.ScreenUpdating = True  
End With  
MsgBox "Строки с текстом " & TextToFindArray(0) & " и " & TextToFindArray(1) & " удалены!", 64, "Конец"  
End Sub  
Удаление скрытых строк  
Sub KillHiddenRows()  
For Each x In ActiveSheet.Rows  
If x.Hidden Then x.Delete  
Next  
End Sub  
 
Удаление используемых скрытых строк или строк с нулевой высотой  
Sub KillUsedHiddenThinRows()  
Dim x  
For Each x In ActiveSheet.UsedRange.Rows  
If x.Hidden Or x.Height = 0 Then x.EntireRow.Delete  
Next  
End Sub
 
тебе с цветом надо разобраться еще. каким индексом твой цвет обозначается я не знаю. у меня вот это еще есть:  
 
Поиск ячейки синего цвета в диапазоне  
 
Sub Макрос1()  
Dim myRange As Range 'диапазон для поиска  
Dim FoundRng As Range 'найденная ячейка  
Dim iRow As Long  
Dim iColumn As Long  
 
Set myRange = Range("B1:B100")  
Application.FindFormat.Interior.ColorIndex = 5 'будем искать синий цвет  
Set FoundRng = myRange.Find(What:="", SearchFormat:=True)  
If Not FoundRng Is Nothing Then  
iRow = FoundRng.Row  
iColumn = FoundRng.Column  
MsgBox "Ячейка найдена по адресу: " & Chr(13) & "Ряд: " & iRow & Chr(13) & "Столбец: " & iColumn, vbInformation, ""  
Else  
MsgBox "Ячейка не найдена!", vbExclamation, ""  
End If  
End Sub
 
Причем здесь цвет?! Автор просто показал нам что нужно оставить.
 
Действительно, пустые строки можно удалить отдельным макросом, то что уважаемый  
North_Rain выложил у меня есть и я кое-чем из этого, особенно "удалением по условию" часто пользуюсь.  
 
А цвет тут действительно не причем, я им просто выделил то, что должно остаться.
 
ммм... я думал у него таблица такая разноцветная. ну ему в любом случае наврено надо как то обозначить свои нужные значения. иначе мне кажется никак не получится остальное удалить, ведь тут фиксированный шаг тоже не задашь. хз. может спецы помогут
 
Таблица не разноцветная, и строк в ней не одна тысяча. Без макроса тут ни как не обойтись.
 
можно так
Живи и дай жить..
 
Это то что надо! Спасибо Слэн!!! Спасибо всем, кто уделил внимание моей проблеме.  
 
Поясните пожалуйста, что нужно изменить в этом макросе, чтоб удалялась строка полностью, а не только у первых двух столбцов. Это в примере всего 2 столбца, на самом деле их 18.
 
Последний вопрос снимается. Разобрался. Ещё раз всем огромное спасибо!!!
 
Народ! Помогите пожалуйста!  
Нужен макрос для удаления строки если в ней заполнено н больше двух ячеек.  
Т.Е. имеется некая таблица в которой есть строки в которых заполнены три ячейки, а есть строки где заполнена только одна или две ячейки. Так вот нужно безжалостно прибить последние два варианта строк.
 
Вот для некой таблицы:  
Sub DelRows()  
Dim iLastRow As Long, i As Long  
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row  
   For i = iLastRow To 1 Step -1  
       If Application.WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, 3))) < 3 Then  
           Rows(i).Delete  
       End If  
   Next  
End Sub
 
К сожалению макрос не срабатывает, вернее в итоге удаляет все строки....  
Прилагаю исходный текст своего макроса в который нужно впихнуть модуль для удаления строк в которых заполнено не больше чем 2 ячейки  
 
Sub Format_Table()  
'  
' Format_Table Макрос  
'  
' Сочетание клавиш: Ctrl+f  
'  
     
    Rows("1:5").Select  
   Selection.EntireRow.Delete  
     
     
   ActiveSheet.Cells.Select  
Selection.Replace What:=".**", Replacement:=""  
Selection.Replace What:="'", Replacement:=""  
Range("A1").Select  
   Application.CutCopyMode = False  
   Range("A1").Select  
   ActiveCell.FormulaR1C1 = "Product"  
   Range("D1").Select  
   ActiveCell.FormulaR1C1 = "Cost"  
   Range("E1").Select  
   ActiveCell.FormulaR1C1 = "Quantity"  
     
   Columns("C:C").Select  
   Application.CutCopyMode = False  
   Selection.ClearContents  
   Columns("F:F").Select  
   Selection.ClearContents  
   Range("A2:E6").Select  
   Selection.Columns.AutoFit  
   Selection.Rows.AutoFit  
   With Selection.Font  
       .Name = "Times New Roman"  
       .Size = 11  
       .Strikethrough = False  
       .Superscript = False  
       .Subscript = False  
       .OutlineFont = False  
       .Shadow = False  
       .Underline = xlUnderlineStyleNone  
       .ThemeColor = xlThemeColorLight1  
       .TintAndShade = 0  
       .ThemeFont = xlThemeFontNone  
   End With  
   Columns("E:E").ColumnWidth = 4  
   Columns("D:D").ColumnWidth = 8  
End Sub  
 
Если что прошу сильно ногами не пинать, я только-только начал осваивать макросы....=)    
Заранее огромное спасибо! =)
 
{quote}{login=Glebsus}{date=07.12.2010 11:56}{thema=}{post}К сожалению макрос не срабатывает, вернее в итоге удаляет все строки...{/post}{/quote}  
Неправда! Макрос отлично работает - удаляет строку, если хотя бы одна из ячеек столбца А, или В, или С не заполнена. Т.е. согласно Вашим условиям.    
Макрос можно вызвать из Вашего кода, вставив в нужном месте строку:  
Call DelRows
 
"Неправда! Макрос отлично работает - удаляет строку, если хотя бы одна из ячеек столбца А, или В, или С не заполнена."  
 
Но Glebsus <> Urfin, и, судя по макросу, у него не 3 столбца! А по 6 столбцам этот макрос запросто вычистит все.  
 
Для правильной работы ввести изменения в строке  
If Application.WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, число столбцов в таблице)))<3 Then
 
{quote}{login=RAN}{date=08.12.2010 12:57}{thema=}{post} судя по макросу, у него не 3 столбца! {/post}{/quote}  
Откуда мне было знать? Автор пишет: "имеется некая таблица в которой есть строки в которых заполнены три ячейки, а есть строки где заполнена только одна или две ячейки" - вот я и сделал для "некой" таблицы. Может быть автор догадается, что нужно конкретнее формулировать, а лучше небольшой файл-пример показывать.
 
Спасибо огромное уважаемый Юрий! Всё действительно работает! Просто необходимо было откорректировать код как было предложено RAN. Да и вопрос конкретнее надо было задавать.... Я всё понял.  
RAN спасибо за пояснение!!!    
=)
 
Приветствую, форумчане! Помогите плз, нужен макрос для удаления строк целиком, если в одной из ячеек присутствует некий текст, в моем случае "Наименование ценности", буду очень признателен.
 
http://yandex.ru/sitesearch?text=%F3%E4%E0%EB%E5%ED%E8%E5+%F1%F2%F0%EE%EA+%EF%EE+%F3%F1%­EB%EE%E2%E8%FE&searchid=84804&web=0&lr=22
 
http://excelvba.ru/code/ConditionalRowsDeleting
 
EducatedFool, не исследовали, на каком количестве элементов Union загибается?  
Код конечно красивый, но вдруг человеку нужно 10к строк скрыть, или 20к?  
У меня на 30к код завис. От чего это зависит - от версии офиса, объёма памяти или фазы Луны - не изучал.
 
> EducatedFool, не исследовали, на каком количестве элементов Union загибается?  
 
Не, зачем мне это?  
В подавляющем большинстве случаев код будет работать (не у всех же строк очень много)  
 
Если у кого-то не получится - обратятся ко мне, придумаю отдельное решение для гигантских объёмов данных.  
 
 
PS: Раньше я внутри подобных циклов проверял, превысило ли количество строк в UNION отметку 1000, и, если превысило, сразу очищал, не дожидаясь окончания цикла.
 
прошу прощения за поднятие старой темы но вот тут присутствует макрос который мне интересен единственный момент что если в строке    
TextToFindArray = Array("Toyota", "ВАЗ")  
я вместо приведенных в примере тойоты и ваза вставляю ОДНО свое значение, он выдает ошибку....как тут быть?  
 
Удаление строки по условию  
Sub Макрос1()  
Dim iRange As Range  
Dim TextToFindArray As Variant  
Dim i As Long  
 
TextToFindArray = Array("Toyota", "ВАЗ")  
With Application  
.ScreenUpdating = False  
.Calculation = xlCalculationManual  
For i = 0 To 1  
With ActiveSheet.Cells  
Set iRange = .Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)  
If Not iRange Is Nothing Then  
Do  
iRange.EntireRow.Delete  
Set iRange = .Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)  
Loop While Not iRange Is Nothing  
End If  
End With  
Next i  
.Calculation = xlCalculationAutomatic  
.ScreenUpdating = True  
End With  
MsgBox "Строки с текстом " & TextToFindArray(0) & " и " & TextToFindArray(1) & " удалены!", 64, "Конец"  
End Sub
 
For i = 0 To UBound(TextToFindArray)  
 
И уберите или как-то переделайте MsgBox - даже так сразу не придумал, что там сделать...  
Просто вывести количество может:  
 
MsgBox UBound(TextToFindArray) + 1 & " строки удалены!", 64, "Конец"
 
А как удалить все строки, где пустая ячейка в столбце B с начиная с 5-ой строки?
 
Есть файлик с двумя листами. на первом - таблица из двух столбцов, кол-во строк может быть любым, пустых нет. на втором листе только один столбец. Нужно, сравнивая значения всех ячеек единственного столбца второго листа со значениями второго столбца первого листа, удалить строки на первом листе с совпадающими значениями.  
 
что-то так накидала, программист из меня не оч..  
и строки не удаляются.. и перепрыгивает даже если условие не выполняется.  
 
Sub macros()  
Dim i As Long  
Dim r As Long  
i = 1  
r = 1  
While Not IsEmpty(Sheets("list2").Cells(i, 1))  
st2 = Sheets("list2").Cells(i, 1).Value  
   While Not IsEmpty(Sheets("list1").Cells(r, 1))  
   st1 = Sheets("list1").Cells(r, 2).Value  
   If StrComp(st1, st2) = 0 Then  
   Rows("r:r").Select  
   Selection.Delete Shift:=xlUp  
   End If  
   r = r + 1  
   Wend  
   r = 1  
   i = i + 1  
     
Wend  
End Sub
 
Sub macros_1()  
Dim i As Long  
Dim r As Long  
i = 1  
r = 1  
While Not IsEmpty(Sheets("list2").Cells(i, 1))  
st2 = Sheets("list2").Cells(i, 1).Value  
   While Not IsEmpty(Sheets("list1").Cells(r, 1))  
   st1 = Sheets("list1").Cells(r, 2).Value  
       If StrComp(st1, st2) = 0 Then  
       Rows®.Delete Shift:=xlUp  
       r = r - 1  
       End If  
   r = r + 1  
   Wend  
i = i + 1  
Wend  
End Sub
 
k61, спасибо за отклик, но строки не удаляются.. ну-кась, пойду пошагово посмотрю....
 
ой, сама проглядела.. в первом столбце на одной из строк случайно пусто оказалось.. и поэтому и непонятно ничего было. а когда все правильно заполнено - все работает отлично!  
 
СПАСИБО, k61!
 
Быстрее взять второй список через массив в Dictionary, затем циклом по первому снизу вверх сверяться с словарём и удалять строки. Ещё быстрее (само удаление) - собирать удаляемые в строку и удалять сразу группой, как обсуждали тут:  
http://www.planetaexcel.ru/forum.php?thread_id=24871&page_forum=2&allnum_forum=52
Страницы: 1 2 След.
Читают тему
Наверх
Loading...