Макрос excel 2010. Оставить строку по определенному условию, лишнее удалить

@strike383 · Регистрация: 24.07.2013

Author24 — интернет-сервис помощи студентам

Здравствуйте, в сети много рабочих макросов для удаление строки в таблице по условию, или по нескольким условиям, так же для удаление пустых и одинаковых строк. Мне же нужно чтоб макрос наоборот оставлял строки с определенным значением а все что не соответствуют условию, удалял.
Тоесть есть большая таблица, нужно чтоб макрос искал в столбце J все записи в начале которых есть значения от 640 до 651 (обязательно в начале, так как в ячейке указаны марки машин номер и позывной, например 640 белая корона номер 237) и оставлял эти строки, а все остальные строки удалял. одинаковых значений может быть несколько а так же может и не быть некоторых чисел, например в таблице может не быть 640, но есть 641, тогда надо оставлять значения от 641 до 651. Как то так, извините за сумбурность, но не знаю как по другому объяснить.

@Alex77755 · 17.01.2014, 19:44

Неужели в готовом макросе трудно поменять условия на свои?

Visual Basic

Sub QWERT()
    Dim R, T
    For R = Cells(Rows.Count, 10).End(xlUp).Row To 1 Step -1
    T = CInt(Left(Cells(R, 10).Value, 3))
        If T < 640 Or T > 651 Then Rows(R).Delete
    Next
End Sub

@strike383 · 17.01.2014, 20:25 **[ТС]**

Нужно не удалить значение с 640 по 651, а наоборот оставить, а остольное удалить

Добавлено через 5 минут
И причем чтоб эти значения были в начале наименования в ячейке, не в середине, не в конце, а в начале. Так как в ячейке кроме 640 есть и другие слова и цифры. Пример: 640 белая корона 237 - так как 640 в начале, строка остается. А если в тексте 237 черная виста 645 - строчка удаляется, так как 645 не в начале

@Alex77755 · 17.01.2014, 23:29

Так там так и сделано
Left как раз и выбирет левые символы

@strike383 · 18.01.2014, 00:07 **[ТС]**

Не работает, пишет ошибку в этой строке

Visual Basic

1	T = CInt(Left(Cells(R, 10).Value, 3))

@Alex77755 · 18.01.2014, 00:25

1. Иногда ругается на Left. напиши VBA.Left
А что говорит?

Добавлено через 1 минуту
И там точно везде впереди 3 цифры? Проверку ж не делал

Добавлено через 9 минут
С пропуском строк с нечислами впереди:

Visual Basic

Sub QWERT()
    Dim R, T
    For R = Cells(Rows.Count, 10).End(xlUp).Row To 1 Step -1
    T = Left(Cells(R, 10).Value, 3)
    If IsNumeric(T) Then
         T = CInt(T)
    Else
        MsgBox "Cтрока " & R & " начинается с " & T, vbCritical, "Пропущена"
        GoTo N
    End If
        If T < 640 Or T > 651 Then Rows(R).Delete
N:
    Next R
End Sub

@strike383 · 18.01.2014, 14:23 **[ТС]**

не работает не Left , не VBA.Left, пишет ошибку:
Run-time error '13':
Type mismatch
и выделяет желтым

Visual Basic

1	T = CInt(Left(Cells(R, 10).Value, 3))

Да, впереди везде 3 цифры, есть и пустые ячейки, должно оставлять только строки, где в начале значения 640-651, все остальные удалять и пустые тоже.
Пример файла ниже, с макросом не могу прицепить, пишет неизвестный файл
Книга3.xlsx
Кстати тут значение надо искать в столбце E, не J и при выполнении макроса еще нужно чтоб удалялась последняя строка, она объединена на все ячейки

@Alex77755 · 18.01.2014, 14:55

Да, впереди везде 3 цифры

Нет! Впереди есть 7 пробелов!
Не применяй для выравнивания пробелы!

Visual Basic

Sub QWERT()
Dim C
C = 5 ' если будет другой номер столбца
    Dim R, T
    For R = Cells(Rows.Count, C).End(xlUp).Row To 2 Step -1
        If Len(Trim(Cells(R, C).Value)) > 0 Then
            T = Left(Trim(Cells(R, C).Value), 3)
            If IsNumeric(T) Then
                 T = CInt(T)
            Else
                MsgBox "Cтрока " & R & " начинается с " & T, vbCritical, "Пропущена"
                GoTo N
            End If
                If T < 640 Or T > 651 Then Rows(R).Delete
N:
        End If
    Next R
    
 Rows(Cells(Rows.Count, 1).End(xlUp).Row).Delete
End Sub

Добавлено через 9 минут
Если удалять и с пустыми полями в колонке то:

Visual Basic

Sub QWERT()
Dim C
C = 5 ' если будет другой номер столбца
    Dim R, T
    For R = Cells(Rows.Count, C).End(xlUp).Row To 3 Step -1
            T = Left(Trim(Cells(R, C).Value), 3)
            If T = "" Then Rows(R).Delete: GoTo N
            If IsNumeric(T) Then
                 T = CInt(T)
            Else
                MsgBox "Cтрока " & R & " начинается с " & T, vbCritical, "Пропущена"
                GoTo N
            End If
                If T < 640 Or T > 651 Then Rows(R).Delete
N: Next R
 Rows(Cells(Rows.Count, 1).End(xlUp).Row).Delete
End Sub

@strike383 · 18.01.2014, 15:29 **[ТС]**

Я ничего не выравнивал, таблица автоматически генерируется в программе и выводится в эксель, нужно чтоб так все работало

@Alex77755 · 18.01.2014, 16:49

А что не работает?

@Alex77755 · 18.01.2014, 16:54

Вот книга

@strike383 · 18.01.2014, 17:17 **[ТС]**

все работает, правда очень долго обрабатывает и мигает экран, но я добавил в начале и конце кода

Visual Basic

1	Application.ScreenUpdating = False

Visual Basic

1	Application.ScreenUpdating = True

и теперь обработка занимает считанные секунды и не мигает экран

@Alex77755 · 18.01.2014, 17:19

Во вложении книга - там уже добавлено!

@strike383 · 18.01.2014, 17:49 **[ТС]**

можете еще помочь? Вообщем сам файл прикреплен ниже, макрос редактирует таблицу, которая выводится с помощью программа и открывается в эксель.
Редактируется следующее, удаляются ненужные столбцы, редактируется ширина, шрифт, удаляется все ненужное кроме 640-551 (то что мы делали выше), убирается цвет таблицы, ресуются границы, далее распечатывается документ шириной в один лист и сохраняется в новом документе без макрос с датой место имени.
Загвоздка в цвете таблиц и гринацах в уже отредактированной таблице. Тоесть должна выделяться таблица с A1 и до F высота не фиксирована, далее убирается цвет и ресуются границы. В коде все работает кроме этого, причем никаких ошибок нет. Сам код:

Visual Basic

Sub Тест()
'
' Тест Макрос
'
' Сочетание клавиш: Ctrl+x
'
   Application.ScreenUpdating = False
    Range("A:A,D:D,E:E,F:F,H:H,K:K,M:M,N:N,O:O,P:P,Q:Q").Delete Shift:=xlToLeft
    Rows("1:1").Delete Shift:=xlUp
    Columns("A:A").ColumnWidth = 17
    Columns("B:B").ColumnWidth = 17
    Columns("C:C").ColumnWidth = 28
    Columns("D:D").ColumnWidth = 20
    Columns("E:E").ColumnWidth = 28
    Columns("F:F").ColumnWidth = 11
    Range("A1:F1").Font.Size = 11
    Rows("1:1").RowHeight = 21
    With Rows("1:1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    'Фильтр
Dim C
C = 5 ' если будет другой номер столбца
    Dim R, T
    For R = Cells(Rows.Count, C).End(xlUp).Row To 3 Step -1
            T = Left(Trim(Cells(R, C).Value), 3)
            If T = "" Then Rows(R).Delete: GoTo N
            If IsNumeric(T) Then
                 T = CInt(T)
            Else
                MsgBox "Cтрока " & R & " начинается с " & T, vbCritical, "Пропущена"
                GoTo N
            End If
                If T < 640 Or T > 651 Then Rows(R).Delete
N: Next R
 Rows(Cells(Rows.Count, 1).End(xlUp).Row).Delete
    Range(Cells(1, 1), Cells(R, 6)).Borders.LineStyle = xlContinuous
    'Убрать цвет
    Range(Cells(1, 1), Cells(R, 6)).Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A1:F1").Select
    'Печать и сохранение.
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.708661417322835)
        .RightMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.748031496062992)
        .BottomMargin = Application.InchesToPoints(0.748031496062992)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 10
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
    strNewName = (Date & ".xlsx")
    If Not Application.Dialogs(xlDialogSaveAs).Show("D:\Отчеты по работе водителей\Отчет общий\" & strNewName) Then _
        MsgBox "Книга не сохранена!", vbExclamation
   Application.ScreenUpdating = True
End Sub

не выполняется это условие

Visual Basic

1	Range(Cells(1, 1), Cells(R, 6))

Книга4.xlsx
В целях конфиденциальности некоторые данные удалены

@Alex77755 · 18.01.2014, 19:27

Всё там работет Только 2 ньюанса:
1. Не стоит работать с Select если можно обойтись без него
2. Хоть бы посмотре что там в R.
Строки удалялись обратным ходом. Поэтому в R , то что было после To в цикле -1. Там 2
Вот и работаешь с этим Range.
Надо просто снова определить размер таблицы.
Вот так может выглядеть блок:

Visual Basic

N: Next R
 
R = Cells(Rows.Count, 1).End(xlUp).Row
 
 Rows(R).Delete
    Range(Cells(1, 1), Cells(R-1, 6)).Borders.LineStyle = xlContinuous
    'Убрать цвет
    Range(Cells(1, 1), Cells(R-1, 6)).Interior.Pattern = xlNone

@strike383 · 19.01.2014, 08:07 **[ТС]**

Спасибо, работает!

@strike383 616 / 0 / 1 Регистрация: 24.07.2013 Сообщений: 93
		1
	Макрос excel 2010. Оставить строку по определенному условию, лишнее удалить 17.01.2014, 19:21. Показов 8633. Ответов 15 Метки нет (Все метки) Здравствуйте, в сети много рабочих макросов для удаление строки в таблице по условию, или по нескольким условиям, так же для удаление пустых и одинаковых строк. Мне же нужно чтоб макрос наоборот оставлял строки с определенным значением а все что не соответствуют условию, удалял. Тоесть есть большая таблица, нужно чтоб макрос искал в столбце J все записи в начале которых есть значения от 640 до 651 (обязательно в начале, так как в ячейке указаны марки машин номер и позывной, например 640 белая корона номер 237) и оставлял эти строки, а все остальные строки удалял. одинаковых значений может быть несколько а так же может и не быть некоторых чисел, например в таблице может не быть 640, но есть 641, тогда надо оставлять значения от 641 до 651. Как то так, извините за сумбурность, но не знаю как по другому объяснить. 0

@strike383 616 / 0 / 1 Регистрация: 24.07.2013 Сообщений: 93
	17.01.2014, 20:25 [ТС]	3
	Нужно не удалить значение с 640 по 651, а наоборот оставить, а остольное удалить Добавлено через 5 минут И причем чтоб эти значения были в начале наименования в ячейке, не в середине, не в конце, а в начале. Так как в ячейке кроме 640 есть и другие слова и цифры. Пример: 640 белая корона 237 - так как 640 в начале, строка остается. А если в тексте 237 черная виста 645 - строчка удаляется, так как 645 не в начале 0

@Alex77755 11508 / 3794 / 681 Регистрация: 13.02.2009 Сообщений: 11,197
	17.01.2014, 23:29	4
	Так там так и сделано Left как раз и выбирет левые символы 1

@strike383 616 / 0 / 1 Регистрация: 24.07.2013 Сообщений: 93
	18.01.2014, 15:29 [ТС]	9
	Я ничего не выравнивал, таблица автоматически генерируется в программе и выводится в эксель, нужно чтоб так все работало 0

@Alex77755 11508 / 3794 / 681 Регистрация: 13.02.2009 Сообщений: 11,197
	18.01.2014, 16:49	10
	А что не работает? 0

@Alex77755 11508 / 3794 / 681 Регистрация: 13.02.2009 Сообщений: 11,197
	18.01.2014, 17:19	13
	Во вложении книга - там уже добавлено! 1

@strike383 616 / 0 / 1 Регистрация: 24.07.2013 Сообщений: 93
	19.01.2014, 08:07 [ТС]	16
	Спасибо, работает! 0