Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удалить все строки, в которых отсутствует определённый текст, результат отразить по вертикали., Создать макрос.
 
#1
20.01.2022 16:54:37
Здравствуйте цифровые люди, помогите с проблемой пожалуйста:Хотелось бы заиметь макрос который "посмотрит" на первый столбец "А" листа под названием "Sheet1" и удалит все строки, кроме тех в которых будет (два условия) текст "Всего:" или "Всего по:", а потом отразит по вертикали (сверху вниз, т. е. последняя строка станет первой, предпоследняя - второй и тк..д..). А еще было бы круто, после действий описанных вверху этот же макрос закрасил строки "Всего по:" в зелёный, а строки в колонке "В" которых стоит значение "260" закрасил в жёлтый.


Отблагодарю чеканной монетой)  
 
 
 
#2
20.01.2022 16:57:27
Файл с примером, что есть и что хотите где?
 
 
 
#3
20.01.2022 17:06:49
Вот, простите.
Лист: Result - желаемый результат
 
 
 
#4
20.01.2022 17:11:32
Установите фильтр и отфильтруйте в столбце по "Всего" и "Всего по", а цвета можно добавить условным форматированием
 
 
 
#5
20.01.2022 17:15:36
Спасибо за ваш отклик, но задача состоит в создании макроса, то что вы предложили - это я умею и использую, но проблема решается не на все 100, а именно в отражении строк снизу вверх.
Изменено: Любитель Excel - 20.01.2022 17:16:42
 
 
 
#6
20.01.2022 17:21:47
В этом разделе: один вопрос - одна тема. Хотите комплексно, можем перенести тему в Работу
 
 
 
#7
20.01.2022 17:22:51
Чеканят монеты здесь
Изменено: _Igor_61 - 20.01.2022 17:24:17
 
 
 
#8
20.01.2022 17:26:24
Сер модератор, если так у меня будет больше шансов на реализацию "моей хотелки", то сделайте это пожалуйста.  
 
 
 
#9
20.01.2022 17:26:39
Можно в PQ
Код
let
  src     = Excel.CurrentWorkbook(){[ Name = "data" ]}[Content],
  filter  = Table.SelectRows ( src, ( x ) => Text.Contains ( Text.From ( Record.FieldValues ( x ){0} ), "Всего" ) ),
  reverse = Table.ReverseRows ( filter )
in
  reverse
Изменено: surkenny - 20.01.2022 17:30:29
 
 
 
#10
20.01.2022 17:36:24
Извините, этот вариант не подходит.  
 
 
 
#11
20.01.2022 17:51:48
Тогда так попробуйте:
Код
Sub Сборка()
arr1 = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row)
m = WorksheetFunction.CountIf(Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row), "Всего по:") * 2
ReDim arr2(1 To m, 1 To 2)
m = 1
For i = UBound(arr1) To 1 Step -1
    If arr1(i, 1) = "Всего:" Then
        arr2(m + 1, 1) = arr1(i, 1)
        arr2(m + 1, 2) = arr1(i, 2)
    ElseIf arr1(i, 1) = "Всего по:" Then
        arr2(m, 1) = arr1(i, 1)
        arr2(m, 2) = arr1(i, 2)
        m = m + 2
    End If
Next
Worksheets("Result").Range("A2").Resize(UBound(arr2), 2) = arr2
End Sub

А РАЗУКРАСИТЬ ЭТО ВТОРОЙ ВОПРОС
Изменено: Msi2102 - 21.01.2022 08:28:23
 
 
 
#12
20.01.2022 17:52:41
Код
Sub Всего()
    Dim y As Long
    Dim arr As Variant
    With ActiveSheet
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 2))
    End With
    
    Dim x As Long
    Dim u As Long
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    For y = UBound(arr, 1) To 1 Step -1
        Select Case arr(y, 1)
        Case "Всего:", "Всего по:"
            u = u + 1
            For x = 1 To UBound(brr, 2)
                brr(u, x) = arr(y, x)
            Next
        End Select
    Next
    Erase arr
    
    If u > 0 Then
        With Workbooks.Add(1)
            With .Sheets(1)
                With .Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
                    .Cells = brr
                    
                    For y = 1 To u
                        If brr(y, 1) = "Всего по:" Then
                            .Rows(y).EntireRow.Interior.Color = 5296274
                        End If
                        If brr(y, 2) = 260 Then
                            .Rows(y).EntireRow.Interior.Color = 65535
                        End If
                    Next
                End With
            End With
            .Saved = True
        End With
    End If
End Sub
 
 
 
#13
20.01.2022 18:01:41
2102 большое вам спасибо за помощь!
Матрос вам монетка нужна, можете сообщить номер вашей копилки?  
 
 
 
#14
20.01.2022 18:55:01
Цитата
Любитель Excel написал:
если так у меня будет больше шансов на реализацию
Будет больше порядка, если не валить вопросы в одну тему. Было бы, если бы...
 
 
 
#15
21.01.2022 11:31:32
Код
Option Explicit

Sub Всего()
'v5
    Dim y As Long
    Dim arr As Variant
    With ActiveSheet
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 1 + 3))
    End With
       
    Dim x As Long
    Dim u As Long
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    For y = UBound(arr, 1) To 1 Step -1
        Select Case arr(y, 1)
        Case "Всего:", "Всего по:"
            u = u + 1
            For x = 1 To UBound(brr, 2)
                brr(u, x) = arr(y, x)
            Next
        End Select
    Next
    Erase arr
       
    If u > 0 Then
        With Workbooks.Add(1)
            With .Sheets(1)
                With .Cells(1, 1).Resize(u, UBound(brr, 2))
                    .Cells = brr
                    .EntireColumn.AutoFit
                       
                    For y = 1 To u
                        If brr(y, 1) = "Всего по:" Then
                            .Rows(y).Interior.Color = 5296274
                        End If
                        If brr(y, 2) = 260 Then
                            .Rows(y).Interior.Color = 65535
                        End If
                    Next
                      
                    Dim vBorder As Variant
'                    For Each vBorder In Array(xlEdgeTop, xlEdgeBottom, xlInsideHorizontal)
'                        With .Borders(vBorder)
                        With .Borders
                            .LineStyle = xlContinuous
                            .ColorIndex = xlAutomatic
                            .TintAndShade = 0
                            .Weight = xlThin
                        End With
'                    Next
                      
                      
                    If MsgBox("Удалить зелёные строки?", vbQuestion + vbYesNo, "Всего") = vbYes Then
                        For y = u To 1 Step -1
                            If .Rows(y).Interior.Color = 5296274 Then
                                .Rows(y).EntireRow.Delete
                            End If
                        Next
                    End If
                      
                End With
            End With
            .Saved = True
        End With
    End If
End Sub
Изменено: МатросНаЗебре - 21.01.2022 16:37:48
 
 
 
Страницы: 1
Наверх