Question

我正在使用VBScript将矩阵中的1个映射到基于映射表的新位置＆＃39;。一切都很有效，直到剧本到达最后一个＆＃39; 1＆＃39;在范围内并回到开头。我希望脚本在整个范围内完成一次搜索后停止循环，并且不再需要再次映射的单元格。

以下是我用来执行映射过程的代码：

Option Explicit

Sub findvalues()
Dim OldRow As Long, OldCol As Long, NewCol As Long, NewRow As Long, OldRowMapped As Long, OldColMapped As Long, i As Integer, txt As String
Dim oldmappingrow As Variant, oldmappingcol As Variant, c As Range, firstAddress As String, cellAddress As String
Dim mappedcells() As Variant
Dim mapagain() As Variant

With Worksheets(1).Range("a1:o15")
    ReDim mappedcells(1)
    ReDim mapagain(1)
    Set c = .Find(1, LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            cellAddress = c.Address                                 ' Finds address of cell containing 1 and converts to Row,Column values
            OldRow = Range(cellAddress).Row
            OldCol = Range(cellAddress).Column

            If Not IsInArray(OldRow & OldCol, mappedcells) And IsInArray(OldRow & OldCol, mapagain) <> True Then             ' Checks that current cell isn't one which has already been mapped

                oldmappingrow = Application.Match(OldRow, Worksheets(1).Range("r3:r16"), 0)
                If Not IsError(oldmappingrow) Then
                OldRowMapped = Worksheets(1).Range("r3:r16").Cells(oldmappingrow).Offset(, 1).Value ' Retrieves row to be mapped to
                End If

                oldmappingcol = Application.Match(OldCol, Worksheets(1).Range("r3:r16"), 0)
                If Not IsError(oldmappingcol) Then
                OldColMapped = Worksheets(1).Range("r3:r16").Cells(oldmappingcol).Offset(, 1).Value ' Retrieves col to be mapped to
                End If

                If OldCol > OldRow Then                                                                             ' Ensures convex/concave connections remain the same
                    NewCol = WorksheetFunction.Max(OldRowMapped, OldColMapped)
                    NewRow = WorksheetFunction.Min(OldRowMapped, OldColMapped)
                Else
                    NewRow = WorksheetFunction.Max(OldRowMapped, OldColMapped)
                    NewCol = WorksheetFunction.Min(OldRowMapped, OldColMapped)
                End If

                If Not .Cells(NewRow, NewCol).Value = 1 Or OldRow & OldCol = NewRow & NewCol Then
                    ReDim Preserve mappedcells(UBound(mappedcells) + 1)                 'Add next array element
                    mappedcells(UBound(mappedcells)) = NewRow & NewCol               'Assign the array element
                Else
                    ReDim Preserve mapagain(UBound(mapagain) + 1)                 'Add next array element
                    mapagain(UBound(mapagain)) = NewRow & NewCol
                End If

                .Cells(NewRow, NewCol) = .Cells(OldRow, OldCol).Value               ' Moves cell contents to mapped Row,Column
                If Not OldRow & OldCol = NewRow & NewCol Then
                    .Cells(OldRow, OldCol).Value = "0"
                Else
                    .Cells(OldRow, OldCol).Value = "1"
                End If

                Set c = .FindNext(c)
                Debug.Print (OldRow & OldCol & " moved to " & NewRow & NewCol)

            ElseIf IsInArray(OldRow & OldCol, mapagain) Then

                oldmappingrow = Application.Match(OldRow, Worksheets(1).Range("r3:r16"), 0)
                If Not IsError(oldmappingrow) Then
                    OldRowMapped = Worksheets(1).Range("r3:r16").Cells(oldmappingrow).Offset(, 1).Value ' Retrieves row to be mapped to
                End If

                oldmappingcol = Application.Match(OldCol, Worksheets(1).Range("r3:r16"), 0)
                If Not IsError(oldmappingcol) Then
                    OldColMapped = Worksheets(1).Range("r3:r16").Cells(oldmappingcol).Offset(, 1).Value ' Retrieves col to be mapped to
                End If

                If OldCol > OldRow Then                                                                             ' Ensures convex/concave connections remain the same
                    NewCol = WorksheetFunction.Max(OldRowMapped, OldColMapped)
                    NewRow = WorksheetFunction.Min(OldRowMapped, OldColMapped)
                Else
                    NewRow = WorksheetFunction.Max(OldRowMapped, OldColMapped)
                    NewCol = WorksheetFunction.Min(OldRowMapped, OldColMapped)
                End If

                If Not .Cells(NewRow, NewCol).Value = 1 Or OldRow & OldCol = NewRow & NewCol Then
                    ReDim Preserve mappedcells(UBound(mappedcells) + 1)                 'Add next array element
                    mappedcells(UBound(mappedcells)) = NewRow & NewCol               'Assign the array element
                Else
                    ReDim Preserve mapagain(UBound(mapagain) + 1)                 'Add next array element
                    mapagain(UBound(mapagain)) = NewRow & NewCol
                End If

                .Cells(NewRow, NewCol) = .Cells(OldRow, OldCol).Value
                .Cells(OldRow, OldCol).Value = "1"

                Set c = .FindNext(c)
                Debug.Print (OldRow & OldCol & " moved to " & NewRow & NewCol)
            Else
            Set c = .FindNext(c)
            End If
                For i = LBound(mappedcells) To UBound(mappedcells)
                Debug.Print "Mapped cells ="; mappedcells(i)
                Next i
                For i = LBound(mapagain) To UBound(mapagain)
                Debug.Print "Map again ="; mapagain(i)
                Next i
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With

End Sub

Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function

我知道代码不是最干净的（抱歉我对VBA很新）但基本上我只需要一个好方法而不是说Loop While Not c Is Nothing And c.Address <> firstAddress，告诉脚本在完整后停止循环在不采取任何行动的情况下骑行。这可能吗？

提前致谢！

Answer 1

只需添加一个＆＃39;退出操作＆＃39;在特定点你需要退出循环

防止脚本在一定数量的循环后循环

1 个答案: