使用条件宏VBA引用外部工作簿

Question

我从互联网上一个非常聪明的人形机器人那里收到了这个VBA;它循环遍历特定范围的列和行，并有条件地格式化每一行。 VBA脚本位置很好，但它只能在每个单独的工作表上运行。

我想要的最终结果是这个VBA存在于静态工作簿中，并附带一个按钮，我希望该按钮然后在另一个打开的工作簿上使用单词＆＃34; XY_ABC＆＃执行此VBA 34;包含在其名称中。

理想情况下，我还希望静态工作簿包含四个单元格，这四个单元格填充rngSource和rngTarget中的四个excel范围，这样就可以动态插入范围，这个条件格式VBA可以真正拥有翅膀。

谢谢，Stack Overflow社区。

Sub SetRangeColorScale(rngTargetSection As Excel.Range, csSource As Excel.ColorScale)
Dim csTarget As ColorScale
Dim csCriterion As ColorScaleCriterion

Set csTarget = rngTargetSection.FormatConditions.AddColorScale(csSource.Type)
 rngTargetSection.FormatConditions(rngTargetSection.FormatConditions.Count).SetFirstPriority
For Each csCriterion In csSource.ColorScaleCriteria
 With csTarget.ColorScaleCriteria(csCriterion.Index)
     .Type = csCriterion.Type
     .FormatColor.Color = csCriterion.FormatColor.Color
     .FormatColor.TintAndShade = csCriterion.FormatColor.TintAndShade
 End With
Next csCriterion
End Sub

Sub GreenYellowRed()
Dim rngSource As Excel.Range
Dim rngTarget As Excel.Range
Dim ws As Excel.Worksheet
Dim objSourceCondition As Object 
'we'll test for ColorScale
Dim rngTargetSection As Excel.Range
Dim FillDirection As String
Dim IncompatibleRangeError As String
Dim SectionIncrement As Long
Dim SectionsCount As Long
Dim i As Long

'change the settings below to suit
Set ws = ActiveSheet
Set rngSource = ws.Range("B3:R3")
Set rngTarget = ws.Range("B4:R100")
 FillDirection = "Rows"
 SectionIncrement = 1

'deletes all existing formats
'you might want to change to just delete
'ColorScales, but for demo purposes
'this works well
rngTarget.FormatConditions.Delete
'checks whether the settings above work together
If Not CompatibleRanges(rngSource, rngTarget, SectionIncrement, _
     FillDirection, IncompatibleRangeError) Then
 MsgBox IncompatibleRangeError, vbOKOnly + vbExclamation
 GoTo exit_point
End If

'determine how many sections of rows or columns
'we'll be pasting over
If FillDirection = "Rows" Then
 SectionsCount = rngTarget.Rows.Count / SectionIncrement
ElseIf FillDirection = "Columns" Then
 SectionsCount = rngTarget.Columns.Count / SectionIncrement
End If

For i = 0 To SectionsCount - 1
 'set an individual section to be pasted over
If FillDirection = "Rows" Then
     Set rngTargetSection = rngTarget((i * SectionIncrement) + 1, 1) _
         .Resize(SectionIncrement, rngTarget.Columns.Count)
 ElseIf FillDirection = "Columns" Then
     Set rngTargetSection = rngTarget(1, (i * SectionIncrement) + 1) _
         .Resize(rngTarget.Rows.Count, SectionIncrement)
 End If
 For Each objSourceCondition In rngSource.FormatConditions
     'test if it's a ColorScale - 3
    If objSourceCondition.Type = 3 Then
         SetRangeColorScale rngTargetSection, objSourceCondition
     End If
 Next objSourceCondition
Next i

exit_point:
End Sub

Function CompatibleRanges(rngSource As Excel.Range, rngTarget As Excel.Range, _
 SectionIncrement As Long, FillDirection As String, _
 ByRef IncompatibleRangeError As String) As Boolean

'no #DIV/0
If SectionIncrement = 0 Then
 IncompatibleRangeError = _
 "You can't use an increment of 0"
 GoTo exit_point
End If
'can't specify a SectionIncrement bigger than the target range
If (FillDirection = "Rows" And rngTarget.Rows.Count < SectionIncrement) Or _
(FillDirection = "Columns" And rngTarget.Columns.Count < SectionIncrement) Then
 IncompatibleRangeError = _
 "Target range must have at least" & vbCrLf & _
     SectionIncrement & " rows."
 GoTo exit_point
End If
'target range rows or columns must be
'evenly divisible by the SectionIncrement
If (FillDirection = "Rows" And rngTarget.Rows.Count Mod SectionIncrement <> 0) Or _
(FillDirection = "Columns" And rngTarget.Columns.Count Mod SectionIncrement <> 0) Then
 IncompatibleRangeError = _
 "Target range " & FillDirection & " must be" & vbCrLf & _
      "evenly divisible by " & SectionIncrement & "."
 GoTo exit_point
End If
'target range width or height has to match
'source range width or height
If Not (rngSource.Rows.Count = rngTarget.Rows.Count Or _
     rngSource.Columns.Count = rngTarget.Columns.Count) Then
 IncompatibleRangeError = _
 "Source and Target ranges must have" & vbCrLf & _
     "either the same number" & vbCrLf & "of rows or columns."
 GoTo exit_point
End If

exit_point:
 CompatibleRanges = IncompatibleRangeError = ""
End Function