Excel vba - 多个条件和多个语句

Question

我对 VBA 编码非常陌生，需要一些帮助。我正在寻找根据不同单元格的值选择范围的代码。

在我的工作表中，我有 7 个单元格，如果我想选择一个范围，则该公式会给单元格一个“X”：

如果 I33 = "X" 则选择 A1: S31（I33 有公式）

如果 I34 = "X" 则选择 T1: AH31（I33 有公式）

我有 7 个……

我在寻找什么；如果 I33、I34、i35、I36、I37、I38 或 I39 中的一个或多个具有“X”，则应选择相应的区域（例如 A1:S31，有 7 个不同的范围）。

感谢您的帮助:-)

Answer 1

你可以试试这个

Option Explicit

Sub main()
    Dim xRangeAdress As Range, rangesAddress() As Range, rangeToSelect As Range, cell As Range
    Dim ws As Worksheet

    Set ws = ThisWorkbook.Worksheets("X-Sheet") '<== change it as per your actual sheet name
    Set xRangeAdress = ws.Range("I33:I39") '<== set the range with "X" formulas: change "I33:I39" as per your actual needs

    Call SetRangeAddresses(rangesAddress(), ws) ' call the sub you demand the addresses settings to

    For Each cell In xRangeAdress 'loop through "X" cells
        If UCase(cell.Value) = "X" Then Set rangeToSelect = MyUnion(rangeToSelect, rangesAddress(cell.Row - 33 + 1)) ' if there's an "X" then update 'rangeToSelect' range with corresponding range
    Next cell
    rangeToSelect.Select
End Sub


Sub SetRangeAddresses(rangeArray() As Range, ws As Worksheet)
    ReDim rangeArray(1 To 7) As Range '<== resize the array to as many rows as cells with "X" formula

    With ws ' type in as many statements as cells with  "X" formula
        Set rangeArray(1) = .Range("A1:S31")   '<== adjust range #1 as per your actual needs
        Set rangeArray(2) = .Range("T1:AH31")  '<== adjust range #2 as per your actual needs
        Set rangeArray(3) = .Range("AI1:AU31") '<== adjust range #3 as per your actual needs
        Set rangeArray(4) = .Range("AU1:BK31") '<== adjust range #4 as per your actual needs
        Set rangeArray(5) = .Range("BL1:BT31") '<== adjust range #5 as per your actual needs
        Set rangeArray(6) = .Range("BU1:CD31") '<== adjust range #6 as per your actual needs
        Set rangeArray(7) = .Range("CE1:CJ31") '<== adjust range #7 as per your actual needs
    End With
End Sub


Function MyUnion(rng1 As Range, rng2 As Range) As Range
    If rng1 Is Nothing Then
        Set MyUnion = rng2
    Else
        Set MyUnion = Union(rng1, rng2)
    End If
End Function

我添加了 cmets 让您学习和开发他的代码以供您进一步了解

Answer 2

只是有一个不同的解决方案（关于你需要选择其中一个）：

Option Explicit

Function MainFull(Optional WS As Variant) As Range
  If VarType(WS) = 0 Then
    Set WS = ActiveSheet
  ElseIf VarType(WS) <> 9 Then
    Set WS = Sheets(WS)
  End If
  With WS
    Dim getRng As Variant, outRng As Range, i As Long
    getRng = WS.Range("I33:I39").Value
    For i = 1 To 7
      If getRng(i, 1) = "x" Then
        If MainFull Is Nothing Then
          Set MainFull = .Range(Array("A1:S31", "T1:AL31", "AM1:BE31", "BF1:BX31", "BY1:CQ31", "CR1:DJ31", "DK1:EC31")(i - 1)) '<- change it to fit your needs
        Else
          Set MainFull = Union(MainFull, .Range(Array("A1:S31", "T1:AL31", "AM1:BE31", "BF1:BX31", "BY1:CQ31", "CR1:DJ31", "DK1:EC31")(i - 1))) '<- change it to fit your needs
        End If
      End If
    Next
  End With
End Function

---

Function MainArray(Optional WS As Variant) As Variant
  If VarType(WS) = 0 Then
    Set WS = ActiveSheet
  ElseIf VarType(WS) <> 9 Then
    Set WS = Sheets(WS)
  End If
  With WS
    Dim getRng As Variant, outArr() As Variant, i As Long, j As Long
    getRng = WS.Range("I33:I39").Value
    i = Application.CountIf(WS.Range("I33:I39"), "x")
    If i = 0 Then Exit Function
    ReDim outArr(1 To i)
    For i = 1 To 7
      If getRng(i, 1) = "x" Then
        j = j + 1
        Set outArr(j) = .Range(Array("A1:S31", "T1:AL31", "AM1:BE31", "BF1:BX31", "BY1:CQ31", "CR1:DJ31", "DK1:EC31")(i - 1)) '<- change it to fit your needs
      End If
    Next
  End With
  MainArray = outArr
End Function

MainFull 返回所有标记范围的整个范围，而MainArray 返回一个数组，其中包含所有标有“x”的范围。

如何使用：

对于MainFull，您可以通过Set myRange = MainFull("Sheet1") 简单地设置范围。这样它就可以很容易地在另一个宏（子）中使用来复制/粘贴到某处。

但如果您需要对每个设置范围（由“x”标记）重复此过程，则需要第二个子，例如：

Dim myRange As Variant
For Each myRange In MainArray("Sheet1")
  ....
Next

然后通过myRange 完成所有工作。如果您还有任何问题，请尽管提问；）