Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удалиение строк. Оставить значения первого столбца с максимальным значением из второго столбца
 
#1
15.01.2020 11:05:43
Добрый день! Просьба помочь с удалением из таблицы строк, оставив только строки с максимальным значением из второго столбца. Количество строк в файле порядка 500 000. Спасибо.
 
 
 
#2
15.01.2020 11:07:56
А нельзя вручную отсортировать по 2 столбцу и удалить? Вроде бы должно быть довольно быстро
Я не волшебник, я только учусь.
 
 
 
#3
15.01.2020 11:12:44
Максимальное для одного № по каталогу? В примере это последнее значение для группы. На это можно ориентироваться?
Если в мире всё бессмысленно, — сказала Алиса, — что мешает выдумать какой-нибудь смысл? ©Льюис Кэрролл
 
 
 
#4
15.01.2020 11:22:01
Должно остаться (для Примера1)
 
 
 
#5
15.01.2020 11:24:04
1. Отсортировать по столбцуА (Всё-равно как) + Столбцу В (второй уровень сортировки + по убыванию).
2. В столбец С вбить формулу =A2=A1.
3. Скопировать и вставить обратно как значения.
4. Отсортировать по столбцу С (для скорости при удалении).
5. Отфильтровать по столбцу С (для удобства).
6. Удалить все строки, в которых в столбце С написано ИСТИНА.
Я не волшебник, я только учусь.
 
 
 
#6
15.01.2020 11:35:08
Код
Sub ОставитьМаксимальные()
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    
    With ActiveSheet
        Dim m As Long:    m = Application.Max(.Columns(2))
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim a As Variant
        a = .Range(.Cells(1, 1), .Cells(y, 2))
    
        For y = 2 To UBound(a, 1)
            If a(y, 2) = m Then
                dic.Item(dic.Count) = a(y, 1)
            End If
        Next
        
        With .Cells(2, 1).Resize(dic.Count, 2)
            .Columns(1).Value = WorksheetFunction.Transpose(dic.Items())
            .Columns(2).Value = m
        End With
        
        .Cells(dic.Count + 2, 1).Resize(y - dic.Count, 2).Clear
        
    End With
End Sub
 
 
 
#7
15.01.2020 11:46:30
Всем огромное спасибо!
 
 
 
#8
15.01.2020 11:53:02
Код
Sub ОставитьМаксимальные()
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
     
    With ActiveSheet
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim a As Variant
        a = .Range(.Cells(1, 1), .Cells(y, 2))
     
        For y = 2 To UBound(a, 1)
            If Not dic.Exists(a(y, 1)) Then
                dic.Item(a(y, 1)) = a(y, 2)
            Else
                If dic.Item(a(y, 1)) < a(y, 2) Then
                    dic.Item(a(y, 1)) = a(y, 2)
                End If
            End If
        Next
         
        With .Cells(2, 1).Resize(dic.Count, 2)
            .Columns(1).Value = WorksheetFunction.Transpose(dic.keys())
            .Columns(2).Value = WorksheetFunction.Transpose(dic.Items())
        End With
         
        .Cells(dic.Count + 2, 1).Resize(y - dic.Count, 2).Clear
         
    End With
End Sub
Так ищет максимальные для каждого номера.
 
 
 
#9
15.01.2020 12:02:39
Код
Sub DelRow()
Dim i As Long
Dim iLastRow As Long
Dim iMax As Double
Dim n As Long
Dim k As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = iLastRow To 3 Step -1
    iMax = Cells(i, "B")
      n = i
    Do
     If Cells(n - 1, "A") = Cells(n, "A") Then
      If Cells(n - 1, "B") > Cells(n, "B") Then iMax = Cells(n - 1, "B")
      n = n - 1
     End If
    Loop While Cells(n - 1, "A") = Cells(n, "A")
    For k = i To n Step -1
      If Cells(k, "B") <> iMax Then Rows(k).Delete
    Next
      i = n
  Next
End Sub
 
 
 
Страницы: 1
Наверх