Question

以下代码是我目前所拥有的。但由于某种原因，它说我有一个没有的下一个soureRow。任何帮助都会很棒。我试图让这个脚本循环遍历第4到第10页，如果行的颜色为黄色或红色，而第1行没有匹配的值。将行复制到工作表1的底部。

target = "Sheet1"

For allSheets = 4 To 10

lastTargetRow = Sheets(target).Range("A" & Rows.Count).End(xlUp).Row

Sheets(allSheets).Activate
lastCurrentRow = Sheets(allSheets).Range("A" & Rows.Count).End(xlUp).Row
For sourceRow = 2 To lastCurrentRow
    If ActiveSheet.Cells(sourceRow, "B").Interior.Color = Yellow Then

        For checkRow = 2 To lastTargetRow
            If ActiveSheet.Cells(sourceRow, "B").Value <> Sheets(target).Cells(checkRow, "B").Value Then
            nRow = Sheets(target).Range("A" & Rows.Count).End(xlUp).Row + 1
            For lCol = 1 To 26       'Copy entire row by looping through 6 columns
                Sheets(target).Cells(nRow, lCol).Value = Sheets(allSheets).Cells(sourceRow, lCol).Value
            Next lCol
            End If

        Next checkRow

    If ActiveSheet.Cells(sourceRow, "B").Interior.Color = Red Then

        For checkRow2 = 2 To lastTargetRow
            If ActiveSheet.Cells(sourceRow, "B").Value <> Sheets(target).Cells(checkRow, "B").Value Then
            nRow = Sheets(target).Range("A" & Rows.Count).End(xlUp).Row + 1

            For lCol = 1 To 26       'Copy entire row by looping through 6 columns
                Sheets(target).Cells(nRow, lCol).Value = Sheets(allSheets).Cells(sourceRow, lCol).Value
            Next lCol

            End If

        Next checkRow2

        End If

Next sourceRow
Next allSheets

Answer 1

这可能会让你更接近：

Sub Tester()

    Const TARGET As String = "Sheet1"

    Dim shtTarget As Worksheet, allSheets As Long, nextTargetRow As Long
    Dim shtTmp As Worksheet, lastCurrentRow As Long, sourceRow As Long
    Dim clr As Long, f As Range, bCell As Range

    Dim myYellow As Long            '<<EDIT
    myYellow = RGB(255, 235, 156)

    Set shtTarget = Sheets(TARGET)
    nextTargetRow = shtTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1

    For allSheets = 4 To 10

        Set shtTmp = Sheets(allSheets)
        lastCurrentRow = shtTmp.Cells(Rows.Count, "A").End(xlUp).Row

        For sourceRow = 2 To lastCurrentRow
            Set bCell = shtTmp.Cells(sourceRow, "B")
            clr = bCell.Interior.Color 'get the color
            'is yellow or red?
            If clr = myYellow  Or clr = vbRed Then
                'look in colB on Target sheet for the value from source
                Set f = shtTarget.Columns(2).Find(bCell.Value, lookat:=xlWhole)
                If f Is Nothing Then
                   'ColB value is not already listed 
                   shtTarget.Cells(nextTargetRow, 1).Resize(1, 26).Value = _
                            shtTmp.Cells(sourceRow, 1).Resize(1, 26).Value
                    nextTargetRow = nextTargetRow + 1
                End If
            End If
        Next sourceRow

    Next allSheets

End Sub

脚本根据bg颜色移动单元格值

1 个答案: