Передайте содержимое нескольких диапазонов в другое подразделение

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 

В сущности я нужен сабвуфер, который содержит следующий код только, а затем принимает различные 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

давайте называть ваш Sub после "DoIt"

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