☰

Совет по макросам — вставка строк на новый лист, если в некоторых ячейках указано «НЕТ»

tag-icon • tag-icon microsoft-excel vba macros
Совет по макросам — вставка строк на новый лист, если в некоторых ячейках указано «НЕТ»

Мне бы хотелось получить совет по использованию VBA и макросов.

Я хотел бы найти способ связать рабочие листы (рабочие листы 1–6) с мастер-листом (рабочий лист 7).

Если строка содержит"НЕТ"в колонке I(по всемурабочие листы 1–6), можно ли скопировать код и вставить эту строку врабочий лист 7?

Тогда если строка (врабочие листы 1–6) был изменен на"ДА" сможет ли другой код удалить эту строку израбочий лист 7?

Для некоторого контекста,рабочие листы 1–6список рабочих мест и'ДА'&'НЕТ'если клиент заплатил. Если'НЕТ'они добавляются в список должниковрабочий лист 7. Если'ДА'их необходимо исключить из списка должников.

решение1

Этот код поможет вам:

Public Sub debtors()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim wksdest As Worksheet
    Set wkb = ThisWorkbook
    Set wksdest = wkb.Sheets("Sheet7")
    wksdest.Rows.Clear 'Clear the contents of Sheet7
    destRow = 1 'First row on Sheet7
    For i = 1 To 6 'Loop through Sheets 1 to 6
        newIndex = Right(Str(i), 1)
        thisSheet = "Sheet" + newIndex
        Set wks = wkb.Sheets(thisSheet)
        wks.Activate
        'Selects column I
        Columns("I:I").Select
        'Find a coincidence with the string "NO"
        Set cell = Selection.Find(What:="NO", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        'If there is a coincidence (is Not Nothing)
        If Not cell Is Nothing Then
            firstRow = cell.Row
            newRow = cell.Row
            'Copy the row and paste on Sheet7
            wks.Rows(newRow).Copy
            wksdest.Rows(destRow).PasteSpecial xlPasteValues
            destRow = destRow + 1
            foundValue = True
            'Find next coincidences in the same sheet
            While foundValue
                Set cell = Selection.FindNext(cell)
                If Not cell Is Nothing Then
                    newRow = cell.Row
                    If newRow <> firstRow Then
                        wks.Rows(newRow).Copy
                        wksdest.Rows(destRow).PasteSpecial xlPasteValues
                        destRow = destRow + 1
                    Else
                        foundValue = False
                    End If
                Else
                    foundValue = False
                End If
            Wend
        End If
    Next i
    wksdest.Activate
End Sub

Откройте VBA/Macros с помощью ALT+ F11, подЭта рабочая книгавставьте новый модуль и вставьте код с правой стороны.

Выполните его, нажав на зеленый треугольник.

Я прокомментировал код, чтобы вы поняли, как он работает.

Вы также можете запустить его пошагово, нажав на первую строку, а затем пройти каждый шаг, нажимая F8.

Связанный контент