檢查數組是否連續，然后刪除vba之間的值

Question

我目前有一個由列表框中的選定項目設置的數組。 我需要知道如何檢查數組中是否有連續的值，然后刪除連續數字的最低值和最高值之間的值。

這是顯示我的意思的示例：

Dim sheets() As Long
Dim Selected As String

ReDim sheets(i)
For i = 1 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
        Selected = ListBox1.List(i)
        ReDim Preserve sheets(i)
        sheets(i) = Selected
    End If
Next i

該數組用於設置打印紙范圍的Solidworks API函數。 這就是為什么我不能擁有兩個以上連續數字的原因。

話雖這么說，但如果有一種基於取消選擇連續列表框項目的簡便方法，我也很樂意這樣做。

謝謝

Answer 1

使用列表框中的這些值（全部選中），您將獲得：

ListBox  Result -> Array(1, 3, 5, 7, 9, 11)
   1        1
   3        3
   4  
   5        5
   7        7
   8  
   9        9
  11       11

---

Option Explicit

Public Sub GetMinMaxOfConsecutives()
    Dim sheets() As Long, i As Long, totalItms As Long
    Dim prev As Boolean, nxt As Boolean, used As Long, this As Long

    used = 1
    With ListBox1    'Sheet1.ListBox1
        totalItms = .ListCount - 1
        ReDim sheets(1 To totalItms)
        For i = 1 To totalItms - 1
            If .Selected(i) Then
                this = .List(i)
                prev = IIf(.Selected(i - 1), this - 1 <> .List(i - 1), True)
                nxt = IIf(.Selected(i + 1), this + 1 <> .List(i + 1), True)
                If prev Or nxt Then
                    sheets(used) = this
                    used = used + 1
                End If
            End If
        Next
        If .Selected(i) Then sheets(used) = .List(i) Else used = used - 1
        If used > 0 Then ReDim Preserve sheets(1 To used) Else ReDim sheets(0)
        'ShowArray sheets
    End With
End Sub

---

Private Sub ShowArray(ByRef arr() As Long)
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        Debug.Print arr(i)
    Next
End Sub

---

編輯：

要將不屬於序列的項加倍，請確保增加初始數組大小以適應這種情況：

ListBox  Result -> Array(1, 1, 3, 3, 5, 5, 7, 7, 9, 9)
   1
   3
   5
   7
   9

---

Public Sub GetMinMaxOfConsecutives2()
    Dim sheets() As Long, i As Long, totalItms As Long
    Dim prev As Boolean, nxt As Boolean, used As Long, this As Long

    used = 1
    With ListBox1
        totalItms = .ListCount - 1

        ReDim sheets(1 To totalItms * 2 + 1)    '<-- double upper bound

        For i = 1 To totalItms - 1
            If .Selected(i) Then
                this = .List(i)

                prev = IIf(.Selected(i - 1), this - 1 <> .List(i - 1), True)
                nxt = IIf(.Selected(i + 1), this + 1 <> .List(i + 1), True)

                If prev Or nxt Then
                    If prev And nxt Then
                        sheets(used) = this
                        used = used + 1
                    End If
                    sheets(used) = this
                    used = used + 1
                End If

            End If
        Next

        If .Selected(i) Then sheets(used) = .List(i) Else used = used - 1
        If used > 0 Then ReDim Preserve sheets(1 To used) Else ReDim sheets(0)
        'ShowArray sheets

    End With
End Sub

---

注意：

如果使用ListFillRange屬性填寫列表框中的項目，請確保您不使用整個列，例如，不要使用"A:A"因為這會將1+ M個項目添加到列表中（即使是空單元格也是如此） ）

如果Microsoft決定在新的Excel版本中將網格大小增加到十億行，則使用列表框將花費很長時間

而是始終使用來自相應列的使用范圍來填充它：

ListBox1.ListFillRange = Sheet1.UsedRange.Columns(1).Address