Question

我对VBA编码很新，需要一些帮助。我正在寻找一个基于不同细胞值选择范围的代码。

在我的表格中，我有7个细胞，这些细胞具有一个公式，可以给细胞一个＆＃34; X＆＃34;如果我想要选择范围：

如果I33 =＆＃34; X＆＃34;然后选择A1：S31（I33有公式）

如果I34 =＆＃34; X＆＃34;然后选择T1：AH31（I33有公式）

我有7个......

我在寻找什么;如果I33，I34，i35，I36，I37，I38或I39中的一个或多个具有＆＃34; X＆＃34;，则应选择相应的区域（示例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

我添加了评论，让您学习和开发他的代码以获得进一步的知识

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返回一个数组，该数组包含标有＆＃34; x＆＃34;的所有范围。

如何使用：

对于MainFull，您只需通过Set myRange = MainFull("Sheet1")设置范围即可。通过这种方式，它可以在另一个宏（sub）中轻松地在其中复制/粘贴它。

但是如果您需要为每个设定范围重复此过程（标记为＆＃34; x＆＃34;），则需要第二个子像：

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

然后通过myRange执行所有操作。如果您还有任何疑问，请询问;）

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

2 个答案: