Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Поиск необходимых значений в таблице и копирование строк в новую таблицу, Макрос
 
Есть таблица, в которой необходимо выявить в колонке E значения, которые больше 30, далее согласно выявленным значениям необходимо скопировать строки в новый лист с сохранением структуры таблицы. При этом колонка F должна перезаписываться на значение 10% и пересчитываться колонка H.

Пытался записать макрос, получилось следующее:
Код
Sub Макрос1()
'
' Макрос1 Макрос
'

'
    ActiveSheet.Range("$A$11:$H$16").AutoFilter Field:=5, Criteria1:=">=30", _
        Operator:=xlAnd
    Range("A12:H16").Select
    Selection.Copy
    Sheets("Лист2").Select
    Range("A12").Select
    ActiveSheet.Paste
    Range("F12").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "10%"
    Selection.AutoFill Destination:=Range("F12:F14"), Type:=xlFillDefault
    Range("F12:F14").Select
    Range("H12").Select
    ActiveCell.FormulaR1C1 = "=PRODUCT(RC[-7],RC[-2],RC[-3])"
    Range("H12").Select
    Selection.AutoFill Destination:=Range("H12:H14"), Type:=xlFillDefault
    Range("H12:H14").Select
End Sub

но это совершенно не то, что необходимо.

Во-первых, получилась привязка к конкретным диапазонам. Хорошо бы, если в коде можно было прописать, чтобы он самостоятельно определял границы таблицы.
Во-вторых, я искал значения больше 30 через фильтр,при этом считаю это не лучшим способом, поскольку к таблице применяется фильтр, который необходимо потом убирать.
В третьих, с таким совершено работать нельзя.

Кто, что думает?

Во вложении пример.  
 
Код
Sub Macro1()
Dim i As Long, LastRow As Long, FreeRow As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    FreeRow = 12
    With Sheets("Лист2")
        For i = 12 To LastRow
            If Cells(i, 5) > 30 Then
                Range(Cells(i, 1), Cells(i, 5)).Copy .Cells(FreeRow, 1)
                .Cells(FreeRow, 6) = 0.1
                .Cells(FreeRow, 8) = .Cells(FreeRow, 1) * .Cells(FreeRow, 5) * Cells(FreeRow, 6)
                FreeRow = FreeRow + 1
            End If
        Next
    End With
End Sub
 
Юрий М, все работает за исключением:
Код
                .Cells(FreeRow, 8) = .Cells(FreeRow, 1) * .Cells(FreeRow, 5) * Cells(FreeRow, 6)
не могу понять почему, но ничего не переумножается. Суммы в ячейках H переносятся с листа 1.
 
Котяра, вместе с рыбой, и точку отглодал.  :D
Код
.Cells(FreeRow, 8) = .Cells(FreeRow, 1) * .Cells(FreeRow, 5) * .Cells(FreeRow, 6)
Изменено: RAN - 19 Сен 2018 08:30:07
 
RAN, точно! Всему виной точка. Как я не заметил. Спасибо!
 
Мой косяк, каюсь )
 
Коллеги, я не учел один момент. В таблицах с которыми приходится работать еще присутствует итоговая строка. Как правильно дополнить макрос, чтобы помимо найденных им значений, которые копируются и переносятся на лист 2 вместе с ними переносилась и итоговая строка, но при этом итоговая строка пересчитывалась.
Изменено: SevenZZ - 19 Сен 2018 23:25:41
 
Какой смысл ПЕРЕНОСИТЬ итоговую строку? Формируйте её заново:
Код
        Next
        .Cells(FreeRow, 7) = "Итого:"
        .Cells(FreeRow, 8) = Application.WorksheetFunction.Sum(Range(.Cells(12, 8), .Cells(FreeRow - 1, 8)))
    End With



 
Цитата
Юрий М написал:
Какой смысл ПЕРЕНОСИТЬ итоговую строку?
В задумке хотелось, чтобы была сохранена структура (формат) строки, иными словами заливка, выравнивание и т.д.
 
Тогда в конце макроса копируйте последнюю строку (диапазон) с первого листа в первую свободную на втором. А как посчитать сумму по столбцу - показано в #8.
 
Юрий М, получилось как-то так. Закрепил в первой строке нужный формат итоговой строки и скрыл ее. Вроде как, все работает. Спасибо.
Код
Sub Macro1()
Dim i As Long, LastRow As Long, FreeRow As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    FreeRow = 12
    With Sheets("Штраф")
        For i = 12 To LastRow
            If Cells(i, 5) > 30 Then
                Range(Cells(i, 1), Cells(i, 8)).Copy .Cells(FreeRow, 1)
                .Cells(FreeRow, 6) = 0.1
                FreeRow = FreeRow + 1
        LastRow = .Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Range(Cells(1, 1), Cells(1, 8)).Copy .Cells(LastRow + 1, 1)
            End If
        Next
        .Cells(FreeRow, 8) = Application.WorksheetFunction.Sum(Range(.Cells(12, 8), .Cells(FreeRow - 1, 8)))
    End With
End Sub
 
Столкнулся с новой проблемой. Отмечу сразу, что макрос написанный, Юрий М, работает в полном совершенстве.
К сожалению, изначально я забыл учесть, что таблица может содержать, так сказать промежуточные итоги.
Следовательно при использовании макроса все значении более 30 переносятся на новый лист так сказать единой таблицей.

Для понимания, прилагаю файл с небольшим примером.

При нажатии кнопки "Расчитать", макрос определит в таблице на листе 1 значения в 5 колонке, которые более 30, после чего перенесет их на лист Н.
Во вкладке "Должно быть" приведен пример, как макрос должен был это сделать.

По сути макрос должен найти значения более 30, далее увидев строку, содержащую надпись "Итого", перенести найденные строки с итоговой строкой, далее продолжить поиск значений более 30, увидев строку, содержащую надпись "Итого", перенести найденные строки с итоговой строкой и так далее.
 
Что же Вы данных поленились добавить? Всего три строки...
Код
Sub Расчитать()
Dim i As Long, LastRow As Long, FreeRow As Long, RowStart As Long, RowFinish As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    FreeRow = 12
    RowStart = FreeRow
    With Sheets("Н")
        For i = 12 To LastRow
            If Cells(i, 5) > 30 Then
                Range(Cells(i, 1), Cells(i, 8)).Copy .Cells(FreeRow, 1)
                .Cells(FreeRow, 6) = 0.1
                FreeRow = FreeRow + 1
'                LastRow = .Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'                Range(Cells(2, 1), Cells(2, 8)).Copy .Cells(LastRow + 1, 1)
            End If
            If Cells(i, 1) Like "Итого" & "*" Then
                Range(Cells(i, 1), Cells(i, 8)).Copy .Cells(FreeRow, 1)
                RowFinish = FreeRow - 1
                .Cells(FreeRow, 8) = Application.WorksheetFunction.Sum(Range(.Cells(RowStart, 8), .Cells(FreeRow - 1, 8)))
                FreeRow = FreeRow + 1
                RowStart = FreeRow
            End If
        Next
    End With
End Sub
 
Юрий М, пытался, но либо ошибка выскакивала, либо вообще ничего. Теперь вижу где косячил. Спасибо Вам.

Единственное в колонке G или если ориентироваться по таблице, то в колонке D местами некорректно встают данные на листе Н, исправляется двойным тапом и enter. Не подскажите в связи с чем так происходит?
 
Там столбец заполняется вызываемой функцией ParseFormula. Зачем у Вас это сделано - не знаю )
 
Юрий М, Просто необходимо, чтобы в столбце G вставала расшифровка соответствующей строки столбца H, собственно, то исходя  из чего получилась данная сумма, поэтому сделал это через
Код
Function ParseFormula(ByRef cell As Range, Optional SubItem As Boolean = False)
    On Error Resume Next
    fo = cell.Formula: fu = Split(Split(fo, "=")(1), "(")(0)
    Dim cel As Range, ra As Range: Set ra = Range(Split(Split(fo, "(")(1), ")")(0))

    Select Case fu
        Case "PRODUCT": s = "*"
        Case "SUM": s = " + "
        Case Else: s = " ??? ": fu = ""
    End Select
    If fu = "" Then ParseFormula = cell.Value: Exit Function

    For Each cel In ra.Cells
        ParseFormula = ParseFormula & s & IIf(fu = "", cel.Value, ParseFormula(cel, True))
    Next cel
    ParseFormula = Mid(ParseFormula, Len(s) + 1)
    If Not SubItem Then ParseFormula = "" & ParseFormula & " = " & cell.Value
End Function

Sub ParseFormula()
    РезультатВычислений = ParseFormula(ActiveCell)
    Debug.Print РезультатВычислений
End Sub
 
А зачем Вы показали код этой функции? Я её вижу в проекте )) Если функция нужна - пусть остаётся. Если нет - удалите.  
 
Юрий М, функция нужна, но почему-то местами отражается некорректно, например, ячейка G14
Скрытый текст
и исправляется это маленькая неприятность двойным тапом по ячейке и энтером. Почему так не пойму.

Конечно это вопрос уже не этой темы, возможно. Поэтому, если, что, прошу модераторов сильно не ругаться.
Изменено: SevenZZ - 23 Сен 2018 14:33:25
 
SevenZZ, перечитайте название Вашей темы - там есть что-нибудь про эту функцию? ))
Вопрос по теме решён?
P.S. Копируйте на всю строку. А значение из этой "плохой" ячейки, забирайте, как текст.
 
Юрий М, вопрос по теме решен однозначно, за это Вам спасибо!
Страницы: 1
Читают тему (гостей: 1)
Наверх