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

Question

下面的代码是我目前所拥有的。但出于某种原因，它说我有一个没有 for 的下一个 soureRow。任何帮助都会很棒。我正在尝试让此脚本循环遍历 sheets 4 到 10，如果该行的 bg 颜色为黄色或红色且 sheet 没有匹配值。将行复制到 sheet 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 颜色移动单元格值的脚本

Script to move cell values according to bg colour

excel

vba

for-loop

copying