数组重新组合

Question

数据源(数组)
x1 :  y1 :  x2 :  y2
1 0 :  2 :  0 :  0
2 1 :  2 :  0 :  2
3 1 :  0 :  1 :  2
4 0 :  0 :  1 :  0 要求数组进行重新组合后,结果如下:
x1 :  y1 :  x2 :  y2
1 0 :  2 :  0 :  0
2 0 :  0 :  1 :  0
3 1 :  0 :  1 :  2
4 1 :  2 :  0 :  2

Answer 1

排版排的好好的,发帖就变了,根本不是我要表述的意思.重发一次
项目 x1 :  y1 :  x2 :  y2
第1点: 0 :  2 :  0 :  0
第2点: 1 :  2 :  0 :  2
第3点: 1 :  0 :  1 :  2
第4点: 0 :  0 :  1 :  0
项目 x1 :  y1 :  x2 :  y2
第1点: 0 :  2 :  0 :  0
第2点: 0 :  0 :  1 :  0
第3点: 1 :  0 :  1 :  2
第4点: 1 :  2 :  0 :  2

Answer 2

重新整理就是对掉问题,现在解法是
Sub llsssss()
  Dim aa(3) As Variant
  aa(0) = Array(0, 2, 0, 0)
  aa(1) = Array(1, 2, 0, 2)
  aa(2) = Array(1, 0, 1, 2)
  aa(3) = Array(0, 0, 1, 0)
  Dim bb(3, 3)
  xx = aa(0)(2): yy = aa(0)(3)
  For jj = 0 To 3
    bb(0, jj) = aa(0)(jj)
  Next jj
  
For kk = 1 To 3
  For ii = 0 To 3
    If xx = aa(ii)(0) And yy = aa(ii)(1) Then
      For jj = 0 To 3
        bb(kk, jj) = aa(ii)(jj)
      Next jj
      xx = aa(ii)(2): yy = aa(ii)(3)
      Exit For
    End If
  Next ii
Next kk
 For ii = 0 To 3
   tt = "  bb(" & ii & ")=array("
   For jj = 0 To 3
     tt = tt & bb(ii, jj) & ","
   Next jj
   tt = Left(tt, Len(tt) - 1)
   tt = tt & ")"
   Debug.Print tt
 Next ii
End Sub
结果为
  bb(0)=array(0,2,0,0)
  bb(1)=array(0,0,1,0)
  bb(2)=array(1,0,1,2)
  bb(3)=array(1,2,0,2)
现在存在的问题是采用了三重嵌套循环,效率太低.
还有一个问题是数组
  aa(0) = Array(0, 2, 0, 0)
  aa(1) = Array(1, 2, 0, 2)
  aa(2) = Array(1, 0, 1, 2)
  aa(3) = Array(0, 0, 1, 0)
也可能是红色部分
aa(1) = Array(0, 2, 1, 2)
按现在办法有问题.

Answer 3

关于你这个问题，要讲的实在太多了。你是想描述一系列矩形、交换矩形元素在数组里的排列、并且可能还需要从字符串里方便里获得矩形的坐标。
下面是我写的一个实现同样目的的代码，希望对你有帮助。测试代码（在测试窗体里）
Private Sub Form_Load()
  Dim tRectangles() As tpRectangle
  Dim tRectangles_Index As Long  tRectangles() = RectanglesGetByCodes("0,2,0,0;1,2,0,2;1,0,1,2;0,0,1,0")
  
  Debug.Print "No Swap"
  
  For tRectangles_Index = 0 To 3
    With tRectangles(tRectangles_Index)
      Debug.Print .rtPointA.ptX, .rtPointA.ptY, .rtPointB.ptX, .rtPointB.ptY
    End With
  Next  Debug.Print "Swap"
  
  RectangleSwap tRectangles(1), tRectangles(3)  For tRectangles_Index = 0 To 3
    With tRectangles(tRectangles_Index)
      Debug.Print .rtPointA.ptX, .rtPointA.ptY, .rtPointB.ptX, .rtPointB.ptY
    End With
  NextEnd Sub
模块代码（要建立一个模块）
Public Type tpPoint
  ptX As Long
  ptY As Long
End TypePublic Type tpRectangle
  rtPointA As tpPoint
  rtPointB As tpPoint
End TypePublic Sub RectangleSwap(ByRef pRectangleA As tpRectangle, ByRef pRectangleB As tpRectangle)
  Dim tRectangle As tpRectangle
  tRectangle = pRectangleA: pRectangleA = pRectangleB: pRectangleB = tRectangle
End SubPublic Function RectanglesGetByCodes(ByVal pCodes As String) As tpRectangle()
  Dim tOutRectangles() As tpRectangle
  Dim tOutRectangles_Length As Long
  Dim tOutRectangles_Index As Long
  Dim tValueStrs() As String
  
  tValueStrs() = Split(pCodes, ";")
  
  tOutRectangles_Length = UBound(tValueStrs())
  
  ReDim tOutRectangles(tOutRectangles_Length)
  
  For tOutRectangles_Index = 0 To tOutRectangles_Length
    tOutRectangles(tOutRectangles_Index) = RectangleGetByCode(tValueStrs(tOutRectangles_Index))
  Next
  
  RectanglesGetByCodes = tOutRectangles()
End FunctionPublic Function RectangleGetByCode(ByVal pCode As String) As tpRectangle
  Dim tOutRectangle As tpRectangle
  
  Dim tValueStrs() As String
  
  tValueStrs() = Split(pCode, ",")
  
  With tOutRectangle
    .rtPointA.ptX = CLng(tValueStrs(0))
    .rtPointA.ptY = CLng(tValueStrs(1))
    .rtPointB.ptX = CLng(tValueStrs(2))
    .rtPointB.ptY = CLng(tValueStrs(3))
  End With
  
  RectangleGetByCode = tOutRectangle
End Function