将几个范围的内容传递给另一个子范围

Question

我有以下代码，我需要传递几个范围（rngSrc和rngTgt）。

 Sub Con_CCC()

 Dim arr, rngSrc As Range, rngTgt As Range, rng As Range, cell As Range
 Dim c As ColorStop
 Dim isGreen As Boolean
 Dim e As Long

 Worksheets("Index Changes").Range("P7:P24").ClearContents

 Set rngSrc = Sheets("Output").Range("J13:J100")
 Set rngTgt = Sheets("Index Changes").Range("Y7")

  For Each cell In rngSrc
   isGreen = False
   On Error Resume Next
     With cell.Interior.Gradient.ColorStops
     End With
     e = Err.Number
   On Error GoTo 0
   If e = 0 Then
     For Each c In cell.Interior.Gradient.ColorStops
         arr = LongToRGB(c.Color)
         If arr(2) / IIf(arr(1) = 0, 1, arr(1)) > 1.25 And arr(2) / IIf(arr(3) = 0, 1, arr(3)) > 1.25 Then
            isGreen = True
            Exit For
         End If
     Next c
  Else
     arr = LongToRGB(cell.Interior.Color)
     If arr(2) / IIf(arr(1) = 0, 1, arr(1)) > 1.25 And arr(2) / IIf(arr(3) = 0, 1, arr(3)) > 1.25 Then isGreen = True
  End If
  If isGreen Then
     If rng Is Nothing Then Set rng = cell.Offset(, -1).Resize(, 2) Else Set rng = Union(rng, cell.Offset(, -1).Resize(, 2))
  End If
Next cell

If Not rng Is Nothing Then rng.Copy: rngTgt.PasteSpecial xlPasteValues

End Sub

本质上我需要一个只包含以下代码的sub，然后在我的其他sub中设置不同的rngSrc和rngTgt。

   For Each cell In rngSrc
    isGreen = False
    On Error Resume Next
     With cell.Interior.Gradient.ColorStops
     End With
   e = Err.Number
  On Error GoTo 0
  If e = 0 Then
    For Each c In cell.Interior.Gradient.ColorStops
     arr = LongToRGB(c.Color)
     If arr(2) / IIf(arr(1) = 0, 1, arr(1)) > 1.25 And arr(2) / IIf(arr(3) = 0, 1, arr(3)) > 1.25 Then
        isGreen = True
        Exit For
     End If
 Next c
Else
   arr = LongToRGB(cell.Interior.Color)
   If arr(2) / IIf(arr(1) = 0, 1, arr(1)) > 1.25 And arr(2) / IIf(arr(3) = 0, 1, arr(3)) > 1.25 Then isGreen = True
 End If
 If isGreen Then
 If rng Is Nothing Then Set rng = cell.Offset(, -1).Resize(, 2) Else Set rng = Union(rng, cell.Offset(, -1).Resize(, 2))
End If
Next cell

 If Not rng Is Nothing Then rng.Copy: rngTgt.PasteSpecial xlPasteValues 

Answer 1

让我们在“DoIt”之后调用你的Sub

Option Explicit

Sub doit(rngSrc As Range, rngTgt As Range)
    Dim cell As Range
    Dim arr, rng As Range
    Dim c As ColorStop
    Dim isGreen As Boolean
    Dim e As Long

    For Each cell In rngSrc
        isGreen = False
        On Error Resume Next
        With cell.Interior.Gradient.ColorStops
        End With
        e = Err.Number
        On Error GoTo 0
        If e = 0 Then
            For Each c In cell.Interior.Gradient.ColorStops
                arr = LongToRGB(c.Color)
                If arr(2) / IIf(arr(1) = 0, 1, arr(1)) > 1.25 And arr(2) / IIf(arr(3) = 0, 1, arr(3)) > 1.25 Then
                    isGreen = True
                    Exit For
                End If
            Next c
        Else
            arr = LongToRGB(cell.Interior.Color)
            If arr(2) / IIf(arr(1) = 0, 1, arr(1)) > 1.25 And arr(2) / IIf(arr(3) = 0, 1, arr(3)) > 1.25 Then isGreen = True
        End If
        If isGreen Then
            If rng Is Nothing Then Set rng = cell.Offset(, -1).Resize(, 2) Else Set rng = Union(rng, cell.Offset(, -1).Resize(, 2))
        End If
    Next cell

    If Not rng Is Nothing Then rng.Copy: rngTgt.PasteSpecial xlPasteValues
End Sub

然后你的“主要”代码将是：

Option Explicit

Sub Con_CCC()
    Dim rngSrc As Range, rngTgt As Range

    Worksheets("Index Changes").Range("P7:P24").ClearContents

    Set rngSrc = Sheets("Output").Range("J13:J100")
    Set rngTgt = Sheets("Index Changes").Range("Y7")

    doit rngSrc, rngTgt '<--| call your 'DoIt()' sub passing 'rngSrc' and 'rngTgt' ranges
End Sub