Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удаление столбцов по условию
 
#1
23.01.2014 12:51:25
Добрый день,
Прошу помочь написать макрос, который удалял бы в массиве данных столбцы по выбранному критерию. Например, удалить столбцы, на пересечении с которыми в шапке (или в i-ой строке массива данных) встречается выражение "....".
За основу я взял аналогичный макрос, который удаляет строки по обозначенному критерию. Но мне не удается переписать его, заменив "rows" на "columns" и наоборот.
'Удаление всех отобранных строк
Код
Sub Rows_Delete_If()
    Dim msg, style, title, Help, Ctxt, Response, MyString
    Dim region As Range, col As Range, checkrange As Range, delrange As Range
    Dim cell As Range

    On Error Resume Next
    If TypeName(Selection) <> "Range" Then Exit Sub

    x = ActiveCell.Value
    Set region = ActiveCell.CurrentRegion
    Set col = ActiveCell.EntireColumn
    Set checkrange = Intersect(region, col)

    If Len(col.Address) > 5 Then
        colName = Mid(col.Address, 2, 2)
    Else
        colName = Mid(col.Address, 2, 1)
    End If

    msg = "Сейчас будут удалены все строки, " & vbCrLf & " где в столбце " & colName & " есть значение '" & x & "'." & vbNewLine & "Продолжить?"
    style = vbYesNo + vbCritical + vbDefaultButton2
    title = "Выборочное удаление строк"

    Response = MsgBox(msg, style, title)

    If Response = vbYes Then
        Call Intro
        Call SaveUndoInfo(ActiveSheet.UsedRange)

        For Each cell In checkrange
            If cell.Value = x Then
                If n = 0 Then
                    Set delrange = cell.EntireRow
                    n = 1
                Else
                    Set delrange = Union(delrange, cell.EntireRow)
                End If
            End If
        Next
        delrange.Delete

    End If
    Call Outro
    Application.OnUndo "Отменить удаление строк", "RestoreUndoInfo"
End Sub
 
 
 
#2
23.01.2014 13:17:26
Вы говорите о виртуальном массиве? Или имеется ввиду массив как набор чего-ло на листе?.
В ваш макрос не стал вдаваться.
Пример приложите.
А если по сути

Код
Sub test()
' перебираем столбцы
For y = 1 To 10
    ' перебираем строки
    For i = 1 To 10
    Cells(i, y).Select
        If (Cells(i, y).Value = "...." Or Cells(i, y).Value = ChrW(8230) & ".") Then
            Columns(y).Delete
            y = y - 1
            GoTo Next_:
        End If
    Next i
Next_:
Next y
End Sub
Проблема в том, что если вы пишите руками .... то первые 3 точки автоматически заменятся на горизонтальное многоточие. Поэтому используем конструкцию Cells(i, y).Value = ChrW(8230) & "."
Макрос работает при условии что .... это содержимое всей ячейки. Если необходимо искать вхождение, то нужно вместо простого сравнения использовать конструкцию InStr
Изменено: Антон - 23.01.2014 13:17:59
 
 
 
#3
23.01.2014 13:27:56
Цитата
нужно вместо простого сравнения использовать конструкцию InStr
я использую LIKE - тестировал на больших массивах - быстрее.
 
 
 
#4
23.01.2014 13:32:00
Цитата
я использую LIKE
постараюсь запомнить). Спасибо.
 
 
 
#5
23.01.2014 13:32:01
Антон, Спасибо.
Массив данных - это таблица. Под "...." я имел в виду любое выражение. Не четыре точки. Простите, что ввел в заблуждение.

Пример прилагаю. В строке 3 есть повторяющееся выражение СРЕДНЯЯ ЦЕНА ПРОДАЖИ (РУБ.)
Мне нужно удалить все столбцы, где в строке 3 встречается такое выражение. Хотелось бы, чтобы макросу можно было задавать номер строки, по которой смотреть (или чтобы он сам понимал это, исходя из того, где стоит курсор), а также задавать само выражение. В следующий раз может потребоваться удалить столбцы, где выражение другое.
 
 
 
#6
23.01.2014 13:45:47
И чем же Вам не подходит макрос?

Код
Sub test()
' перебираем столбцы 
' 200 - это как бы последний столбец
For y = 1 To 200
    ' перебираем строки 
' если нужна 3-я строка, комментируем цикл for и жестко говорим что i=3 либо меняем for 
    For i = 3 To 3
    Cells(i, y).Select
     If (Cells(i, y).Value = "СРЕДНЯЯ ЦЕНА ПРОДАЖИ (РУБ.)" ) Then
Код
      Columns(y).Delete
      y = y - 1
      GoTo Next_:
     End If
    Next i
Next_:
Next y
End Sub
  
 
 
 
#7
23.01.2014 13:55:10
Антон, огромное спасибо!

Очень подходит! Теперь я понял.
 
 
 
#8
23.01.2014 14:28:28
Yohann, оформляйте код тегом и уберите пустые строки в сообщениях.
 
 
 
#9
03.08.2023 20:01:42
Доброго вечера!

Пытаюсь доработать макрос так, чтобы он удалял все столбцы, кроме нужных мне. Пока никак не получается — без i = i-1 удаляет вообще какие-то левые столбцы, которых нет в списке, а с i = i -1 вообще удаляет всё и вешает Excel.

Буду благодарен за любую помощь, глаза уже в кучу... Пример файла для обработки прилагается.

Заранее спасибо.

Код
Sub Обработка_статистики_новый1()
'
' Обработка_статистики_новый1 Макрос
'
      For i = 1 To 100 ' цикл от первого столбца до последнего
      Cells(1, i).Select
         If (Cells(1, i).Value = "Название сделки" Or Cells(1, i).Value = "WC total" Or _
         Cells(1, i).Value = "Бюджет" Or Cells(1, i).Value = "Переводчик" Or _
         Cells(1, i).Value = "WC переводчика (факт)" Or Cells(1, i).Value = "Ставка переводчика" Or _
         Cells(1, i).Value = "Сумма" Or Cells(1, i).Value = "Редактор" Or _
         Cells(1, i).Value = "WC редактора (факт)" Or Cells(1, i).Value = "CAT" Or _
         Cells(1, i).Value = "Ставка редактора" Or Cells(1, i).Value = "" Or _
         Cells(1, i).Value = "Дедлайн" Or Cells(1, i).Value = "Постобработка" Or _
         Cells(1, i).Value = "Верстальщик" Or Cells(1, i).Value = "Объём вёрстки" Or _
         Cells(1, i).Value = "Стоимость вёрстки" Or Cells(1, i).Value = "Примечания общие" Or _
         Cells(1, i).Value = "Примечание 1" Or Cells(1, i).Value = "Примечание 2" Or _
         Cells(1, i).Value = "Примечание 3" Or Cells(1, i).Value = "Примечание 4" Or _
         Cells(1, i).Value = "Примечание 5" Or Cells(1, i).Value = "(До)внести стат. в SC" Or _
         Cells(1, i).Value = "Ссылка в CAT/TMS") Then Else ' сравнение текста с ячейкой
         Columns(i).Delete ' удалить столбец(i)
         i = i - 1
      Next i
    
End Sub
 
 
 
#10
03.08.2023 20:25:17
1. смените имя, или вас как величать? десятый с точностью до третьего знака или ....
2. Удаляют или в обратном порядке, что при удалении не сбивает индексацию столбцов или все сразу определив что удалять.
3. Сделайте список того что нужно удалить или не удалить и прверяйте тоже в цикле.
Код
FieldList=Array("Название сделки", "WC total" , "Бюджет" ....
For i = 100 To 1
flag = true
For each Fiel in  FieldList
if Cells(1, i).Value = Fiel then Flag = false 
next

4 а уже на основании этого либо диапазон столбцов под удаление собирайте (тогда можно брать прямой порядок) или удаляйте столбец
Код
if Flag then Columns(i).Delete
По вопросам из тем форума, личку не читаю.
 
 
 
#11
04.08.2023 15:25:10
Код
Sub qq()
    Dim i&, r As Range
    For i = 1 To 100
        Select Case Cells(1, i).Value
        Case "Название сделки", "WC total", "Бюджет", "Переводчик", "WC переводчика (факт)", "Ставка переводчика", "Сумма", "Редактор", "WC редактора (факт)", "CAT", "Ставка редактора", "", "Дедлайн", "Постобработка", "Верстальщик", "Объём вёрстки", "Стоимость вёрстки", "Примечания общие", "Примечание 1", "Примечание 2", "Примечание 3", "Примечание 4", "Примечание 5", "(До)внести стат. в SC", "Ссылка в CAT/TMS"
            If Not r Is Nothing Then
                Set r = Union(r, Columns(i))
            Else
                Set r = Columns(i)
            End If
        End Select
    Next
    r.Delete
End Sub
 
 
 
#12
04.08.2023 15:45:08
Спасибо огромное. Есть проблема — макрос удаляет столбцы с указанными именами, а надо их оставлять) Попытался поменять выражения под Then и Else местами, выдаёт ошибку.
 
 
 
#13
04.08.2023 15:58:44
Код
Case "Название сделки", "WC total", "Бюджет", "Переводчик", "WC переводчика (факт)", "Ставка переводчика", "Сумма", "Редактор", "WC редактора (факт)", "CAT", "Ставка редактора", "", "Дедлайн", "Постобработка", "Верстальщик", "Объём вёрстки", "Стоимость вёрстки", "Примечания общие", "Примечание 1", "Примечание 2", "Примечание 3", "Примечание 4", "Примечание 5", "(До)внести стат. в SC", "Ссылка в CAT/TMS"
Case Else
            If Not r Is Nothing Then
 
 
 
#14
04.08.2023 16:05:52
Цитата
написал:
Case Else
Потрясающе...

Всё работает. Спасибо огромное.
 
 
 
Страницы: 1
Наверх