从阵列VBA创建范围值

Question

我是VBA的新手。有人能帮我一下吗？

我有两个数组

Pages=(1,2,3,4,5,6,7,8,9,10)
Exclusion=(1,1,3,3,7)

我想写一段代码来比较数组，并给出一个输出，如下所示

(1,2,3,4-6,7,8-10)

在迭代页面数组时，如果值在排除数组上可用，我希望保留结果数组中的单个元素，否则应对值进行分组

Answer 1

这需要一点精确度，我希望我没弄错。这是我构造的函数。它没有将这4个放在一个单独的组中，因为它没有在排除中列出，但它肯定需要比我所做的更多的测试。做我的客人，哈哈：

Function Pagelist(Pages As Variant, _
                  Exclusions As Variant) As String
    ' 015

    Dim Fun() As String
    Dim n As Long
    Dim Excl As String
    Dim Sp() As String
    Dim i As Long

    ReDim Fun(LBound(Pages) + UBound(Pages))
    Excl = "," & Join(Exclusions, ",") & ","

    For i = LBound(Pages) To UBound(Pages)
        If InStr(Excl, "," & Pages(i) & ",") Then
            If Len(Fun(n)) Then n = n + 1
            Fun(n) = Pages(i)
            n = n + 1
        Else
            If Len(Fun(n)) Then
                Sp = Split(Fun(n), "-")
                If UBound(Sp) = 0 Then ReDim Preserve Sp(1)
                Sp(1) = Pages(i)
                Fun(n) = Join(Sp, "-")
            Else
                Fun(n) = Pages(i)
            End If
        End If
    Next i

    If n Then ReDim Preserve Fun(n)
    Pagelist = Join(Fun, ",")
End Function

出于测试目的，您可以使用如下所示的过程调用该函数。

Private Sub Test()

    Dim Pages As Variant
    Dim Exclusions As Variant

    Pages = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
    Exclusions = Array(1, 1, 3, 3, 7)
    Debug.Print Pagelist(Pages, Exclusions)
End Sub

Answer 2

我避免使用另一个函数来编写OutRange (这将是更好、更干净的代码，但这不是主题)

Option Explicit

'Pages need to be in ASCendent order
Function GetPageRanges(Pages() As Variant, Exclusion() As Variant) As String

    GetPageRanges = ""

    'Dim Pages(), Exclusion As Variant
    Dim OutRange(0 To 1) As Variant
    Dim Page As Variant
    Dim SExcl As String

   ' Pages = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
    'Exclusion = Array(1, 1, 3, 3, 7)
    SExcl = "," & Join(Exclusion, ",") & "," 'Every page is sorrounded by commas

    OutRange(0) = Null
    OutRange(1) = Null

    For Each Page In Pages
        'Comma-sorrounding is used in order to delimit page number
        '(searching for "2" in a string will match even when it contains page "123").
        'Searching for ",2," will not match with ",123,"

        If InStr(SExcl, "," & Page & ",") Then
            'Page is in Exclusion list
            'Previous range, if existing, has to be written as range excluding this page.
            'If previus range has only a left/lower bound than it has to be written as a single page.
            'After that also this page has to be written as a single page

            If Not IsNull(OutRange(0)) Then
                'There was a range or a single page
                GetPageRanges = GetPageRanges & OutRange(0)
                If Not IsNull(OutRange(1)) Then GetPageRanges = GetPageRanges & "-" & OutRange(1)
                GetPageRanges = GetPageRanges & ","

                'Clean OutRange
                OutRange(0) = Null
                OutRange(1) = Null
            End If

            'Add this page (found in exclusion)
            GetPageRanges = GetPageRanges & Page & ","

        Else
            'Page is NOT in Exclusion list

            'If OutRange is not started I put page as left/lower bound
            If (IsNull(OutRange(0))) Then
                OutRange(0) = Page
            Else
                'If the range is the one following the left/lower bound then it's inside the same range
                'If this page is the one following the previous right/upeer bound then it's inside the same range.
                'If some page has been skipped the range has to be closed , written and a new open it's opened
                If ((OutRange(0) + 1) = Page) Then
                    OutRange(1) = Page
                ElseIf (CInt(OutRange(1) + 1) = Page) Then
                    'Same action of the if statement expression. We need to use else if in order to use
                    'CInt(OutRange(1)) only if we know that it's not null
                    OutRange(1) = Page
                Else
                    'Like when an excluded page is found, we write down out range and clean it
                    GetPageRanges = GetPageRanges & OutRange(0)
                    If Not IsNull(OutRange(1)) Then GetPageRanges = GetPageRanges & "-" & OutRange(1)
                    GetPageRanges = GetPageRanges & ","
                    OutRange(0) = Null
                    OutRange(1) = Null

                    'This page is written for next range left/lower bound
                    OutRange(0) = Page
                End If

            End If

        End If
    Next Page

    'If the last page was not in exclusion than we have to write down OutRange
    GetPageRanges = GetPageRanges & OutRange(0)
    If Not IsNull(OutRange(1)) Then GetPageRanges = GetPageRanges & "-" & OutRange(1)
    GetPageRanges = GetPageRanges & ","

    'Remove last character (is a comma)
    If GetPageRanges <> "" Then GetPageRanges = Left(GetPageRanges, Len(GetPageRanges) - 1)
End Function

Sub Run()
    Dim Pages() As Variant
    Dim Exclusion() As Variant

    Pages = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
    Exclusion = Array(1, 1, 3, 3, 7)

    Debug.Print GetPageRanges(Pages, Exclusion)

End Sub

Answer 3

获取页面排除

Option Explicit

Function getPagesExclusion(Pages As Variant, Exclusion As Variant, _
  Optional Delimiter As String = "-") As Variant

    Dim Resultant As Variant
    Dim CurrentValue As Long
    Dim StartValue As Long
    Dim EndValue As Long
    Dim i As Long
    Dim k As Long
    Dim Result As String

    For i = 0 To UBound(Pages)
        CurrentValue = Pages(i)
        If Not IsError(Application.Match(CurrentValue, Exclusion, 0)) Then
            GoSub Found
            GoSub FoundCurrent
        Else
            GoSub NotFound
        End If
    Next i
    GoSub Found

    getPagesExclusion = Resultant

GoTo exitProcedure

Found:
    If StartValue <> 0 Then
        If EndValue > StartValue Then
            Result = StartValue & Delimiter & EndValue
        Else
            Result = EndValue
        End If
        GoSub writeToResultant
    End If
Return

FoundCurrent:
    Result = CurrentValue
    GoSub writeToResultant
    StartValue = 0
    EndValue = 0
Return

NotFound:
    If StartValue = 0 Then StartValue = CurrentValue
    EndValue = CurrentValue
Return

writeToResultant:
    If k > 0 Then ReDim Preserve Resultant(k) Else ReDim Resultant(0) As String
    Resultant(k) = Result: k = k + 1
Return

exitProcedure:

End Function

Sub getPagesExclusionExample()

    Dim Pages As Variant
    Dim Exclusion As Variant
    Dim Resultant As Variant

    Pages = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
    Exclusion = Array(1, 1, 3, 3, 7)

    Resultant = getPagesExclusion(Pages, Exclusion)

    Debug.Print Join(Resultant, ", ")

    'or:

    Dim i As Long
    Resultant = getPagesExclusion(Pages, Exclusion, " To ")
    For i = 0 To UBound(Resultant): Debug.Print Resultant(i): Next i

End Sub