Скопируйте диапазон ячеек с исключением

Question

У меня есть код ниже, и я надеюсь, что вы могли бы помочь

Код в настоящее время в основном предназначен для копирования диапазона ячеек в активном рабочем листе или во всех других рабочих листах, настроенных таким же образом. Как только код идентифицирует «НЕТ», которое находится в диапазоне ячеек S26: S69, он будет копировать значения ячеек при нажатии кнопки команды.

Однако этот код работает на 100% все хорошо. Мне было просто интересно, хотя я говорю код для копирования при обнаружении NO в диапазоне S, я в то же время хотел бы переопределить идентификацию NO. Поэтому, если код видит NO, он будет копировать, но, поскольку он затем увидит «Поиск повторов» (который будет находиться в диапазоне строк R26: R69), он не будет копировать инструкцию NO, поскольку диапазон R переопределяет этот запрос независимо от того, выбрано NO или нет.

Я надеюсь, что все имеет смысл

Sub Submit_AuditSheet_Data()

    Dim cell As Range

    Set ws_from = ActiveSheet
    Set ws_to = Sheets("Findings_Summary_Sheet")
    lrow = ws_to.Cells(Rows.Count, "A").End(xlUp).Row
    ' finds that last used row in column "A"

    For Each cell In ws_from.Range("S26:S69")

        If cell.Value = "No" Then

            lrow = lrow + 1
            ws_to.Range("A" & lrow).Value = ws_from.Range("B" & cell.Row).Value
            ws_to.Range("B" & lrow).Resize(1, 14).Value = cell.EntireRow.Columns("O:AB").Value

        End If
    Next cell
End Sub

Answer 1

Копирование с двумя критериями

Код

' Use 'Option Explicit' because it will force you to qualify all variables
' and help you to find errors much faster.
Option Explicit

Sub Submit_AuditSheet_Data()

    ' It is good practice to describe or name the variables.
    ' It is good practice to 'throw in' a CAPITALIZED letter in the variables,
    ' which will make finding typos quicker. This is usually preferred
    ' to using underscores (_).
    Dim ws_From As Worksheet   ' Source Sheet
    Dim ws_To As Worksheet     ' Target Sheet
    ' 'cell' is fine, because 'Cell' is more difficult to identify if there
    ' are instances of the 'Range.Cells' property in the code.
    Dim cell As Range          ' Current Criteria Cell Range
    Dim lRow As Long           ' Last Non-Empty Row (in Column 'A'
                               ' of Target Sheet (ws_To))
    Dim NoRec As Long          ' Number of Records Copied

    ' Using ActiveSheet is usually bad practice.
    ' For example, select the sheet "Findings_Summary_Sheet" and go to VBE.
    ' Now run the code. In this case it probably will find nothing to copy
    ' because the ActiveSheet is the wrong sheet ("Findings_Summary_Sheet").
    ' In a worse case scenario it could overwrite same valuable data.
    ' On the other hand, if the code is in a module and you're going to put
    ' a commandbutton (that will run this code) on several sheets
    ' then it's even a must, because the ActiveSheet will be the one
    ' containing the command button.
    ' Developer > Controls > Insert > ActiveX Controls > Command Button...
    ' CommandButton1 code:
    'Private Sub CommandButton1_Click()
    '    Submit_AuditSheet_Data
    'End Sub
    Set ws_From = ActiveSheet
    ' It is fine to use spaces in sheet (tab) names.
    Set ws_To = Sheets("Findings_Summary_Sheet")
    ' Although it's not necessary in this case, it is good practice to use
    ' 'ws_To.Rows.Count' instead of 'Rows.Count'.
    ' Consider learning how to calculate the last non-empty row using
    ' the Find method since the 'xlUp' method might give you the wrong
    ' result if you have filtered data or hidden rows in the sheet.
    lRow = ws_To.Cells(Rows.Count, "A").End(xlUp).Row
    NoRec = lRow

' While developing the code, use 'Debug.Print' to monitor (current) results
' of variables. When done, delete or better outcomment the 'Debug.Print' lines,
' because they will slow down your code (Think thousands of lines).

' See the results of Debug.Print in the Immediate window (GTRL+G).
Debug.Print String(40, "-")
Debug.Print "ws_From      = " & ws_From.Name
Debug.Print "ws_To        = " & ws_To.Name
Debug.Print "lRow (ws_To) = " & lRow & " (" & ws_To.Name & ")"
Debug.Print String(40, "-")

    For Each cell In ws_From.Range("S26:S69")
        ' Write down the logic your are trying to apply:
        ' Copy ranges if 'R' <> "Repeat Finding, but only if 'S' = "No" or
        ' Copy ranges if 'S' = "No", but only if 'R' <> "Repeat Finding".
        If cell.Offset(, -1) <> "Repeat Finding" Then
            ' Now when you think about it, you can actually switch
            ' the previous and the next line.
            If cell.Value = "No" Then

                lRow = lRow + 1
                ws_To.Range("A" & lRow).Value = _
                  ws_From.Range("B" & cell.Row).Value
                ws_To.Range("B" & lRow).Resize(1, 14).Value = _
                  cell.EntireRow.Columns("O:AB").Value

' See the results of Debug.Print in the Immediate window (GTRL+G).
Debug.Print cell.Address(False, False), _
  cell.Offset(, -1).Address(False, False), _
  ws_To.Range("A" & lRow).Address(False, False), _
  ws_From.Range("B" & cell.Row).Address(False, False), _
  ws_To.Range("B" & lRow).Resize(1, 14).Address(False, False), _
  cell.EntireRow.Columns("O:AB").Address(False, False)

            End If

        End If

    Next cell

' See the results of Debug.Print in the Immediate window (GTRL+G).
Debug.Print String(40, "-")
Debug.Print "lRow (ws_To) = " & lRow & " (" & ws_To.Name & ")"
Debug.Print String(40, "-")

    ' It is good practice to end such a code with a message, because
    ' sometimes it is hard to tell if the code has already run.
    Dim strMsg As String
    NoRec = lRow - NoRec

' See the results of Debug.Print in the Immediate window (GTRL+G).
Debug.Print "NoRec        = " & NoRec
Debug.Print String(40, "-")

    If NoRec <> 1 Then strMsg = "s"
    MsgBox "Copied " & NoRec & " record" & strMsg & ".", _
      vbInformation, "Audit Sheet Data Submitted"

End Sub

Образец результата из непосредственного окна

----------------------------------------
ws_From      = Sheet1
ws_To        = Findings_Summary_Sheet
lRow (ws_To) = 1 (Findings_Summary_Sheet)
----------------------------------------
S35           R35           A2            B35           B2:O2         O35:AB35
S37           R37           A3            B37           B3:O3         O37:AB37
S39           R39           A4            B39           B4:O4         O39:AB39
S41           R41           A5            B41           B5:O5         O41:AB41
S45           R45           A6            B45           B6:O6         O45:AB45
S49           R49           A7            B49           B7:O7         O49:AB49
S50           R50           A8            B50           B8:O8         O50:AB50
S53           R53           A9            B53           B9:O9         O53:AB53
S55           R55           A10           B55           B10:O10       O55:AB55
S58           R58           A11           B58           B11:O11       O58:AB58
S64           R64           A12           B64           B12:O12       O64:AB64
S65           R65           A13           B65           B13:O13       O65:AB65
S67           R67           A14           B67           B14:O14       O67:AB67
----------------------------------------
lRow (ws_To) = 14 (Findings_Summary_Sheet)
----------------------------------------
NoRec        = 13
----------------------------------------

Образец окна сообщения