Question

我想运行一个脚本来查找在Sheet1上突出显示黄色的单元格，如果是黄色，则复制/粘贴到Sheet2。下面的代码似乎应该可行，但它在这一行上失败了。

rc.Copy rd

基本上，我想在Sheet1上的第2,3和17列中连接值，并将所有内容复制/粘贴到Sheet2。我猜测我错过了某种工作表参考，但我不确定，并且到目前为止没有什么对我有用。但是......我觉得这很接近!!任何帮助表示赞赏！

Sub ColorCopier()
Dim i As Long
Dim j As Long
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Version Control")
LRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1

    'k = 1
    Set rc = Sheets("Cobrand Tasklist").UsedRange
    For i = 1 To rc.Rows.Count
        For j = 1 To rc.Columns.Count

            If Cells(i, j).Interior.ColorIndex = 6 Then

                    If j = 2 Then
                    Set rc = Cells(i, j)
                    Set rd = Sheets("Version Control").Cells(LRow, 4)
                        rc = "Task #" & rc
                        rc.Copy rd
                    End If

                    If j = 3 Then
                    Set rc = Cells(i, j)
                    Set rd = Sheets("Version Control").Cells(LRow, 4)
                        rc = "Task Title " & rc
                        rc.Copy rd
                    End If

                    If j = 17 Then
                    Set rc = Cells(i, j)
                    Set rd = Sheets("Version Control").Cells(LRow, 4)
                        rc = "Task Description " & rc
                        rc.Copy rd
                    End If

                LRow = LRow + 1
            End If
        Next
    Next
End Sub

Answer 1

你真的可以压缩代码以停止重复相同的代码。但是，我按照你的方式离开了它，以说明做我认为你想做的事情的不同方式。

Dim i As Long
Dim j As Long
Dim sht As Worksheet
Dim LastRow As Long
Dim rng As Range
Dim str As String
Dim rng As Range

'
Set sht = ThisWorkbook.Worksheets("Version Control")
LRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1

    'k = 1
    Set rc = Sheets("Cobrand Tasklist").UsedRange
    For i = 1 To rc.Rows.Count
        For j = 1 To rc.Columns.Count

            If Cells(i, j).Interior.ColorIndex = 6 Then

                    If j = 2 Then
                    Cells(i, j).Value = "Task #" & Cells(i, j).Value
                    If Not rng Is Nothing Then Set rng = Union(rng, Cells(i, j)) Else Set rng = Cells(i, j)
                    End If

                    If j = 3 Then
                    Cells(i, j).Value = "Task Title " & Cells(i, j).Value
                    If Not rng Is Nothing Then Set rng = Union(rng, Cells(i, j)) Else Set rng = Cells(i, j)
                    End If

                    If j = 17 Then
                    Cells(i, j).Value = "Task Description " & Cells(i, j).Value
                    If Not rng Is Nothing Then Set rng = Union(rng, Cells(i, j)) Else Set rng = Cells(i, j)
                    End If

                LRow = LRow + 1
            End If
        Next
    Next
    rng.Copy Sheets("Version Control").Cells(LRow, 4)

在一行中进行复制和粘贴，而不是每次在循环中进行复制和粘贴都会极大地加速你的代码。

如何完全限定从Sheet1复制并粘贴到Sheet2的范围？

1 个答案: