Extracting profile data from profile measurement

Profile survey is a common engineering survey item , Theodolite traverse setting out used in early profile survey , Measure the elevation of the terrain transformation point , Now use GPS Setting out measures the elevation of terrain transformation points , Greatly improved efficiency . But expand the elevation point to CAD Back of the picture , How to quickly and efficiently convert the elevation data on the map into profile data , There has been no way to combine , Here is a program for automatically outputting profile data .

1. There are data

1.1 The center line is a complete lightweight polyline (LWPolyline), Both ends intersect with the section location line of the head and tail stations . See the red line in the figure below .

1.2 The section location line is a straight line (line) Or a lightweight polyline with two points (LWPolyline), You face upstream , The positioning line is drawn from left to right , Each locating line shall intersect with the centerline . As the black line in the above figure

1.3 Section name ( Stations ) It's a text annotation (Text), The insertion point should be at the intersection of the locating line and the centerline 3m within .

1.4 Elevation points can be attribute blocks (INSERT), It can also be a text annotation (Text), Preferably attribute blocks , The insertion point is on the 2m Within the scope of .

2、 Format of output section data

2.1 The format of this program

The format of the profile data output from this program is the vertical and horizontal profile in one number axis format , Among them, the longitudinal section only has the elevation at the intersection with the positioning line of the transverse section . Such as ：

K0+0,42.05,42.00

-7.66,43.75,-5.80,42.23,0.00,42.05,9.70,42.18,15.15,44.03

~

first line ：K0+0 Is the section name ( Stations ),42.05 Is the elevation of the pile point of the longitudinal section ,42.00 The water is high

The second line ： distance 1, Altitude 1, distance 1, Altitude 1,*** distance n, Altitude n

*** The distance of the longitudinal section pile point is included in the section name , Such as K1+140 The extracted distance is 1140m.

*** The high score of water surface is ：1 You don't need high water ;2 Fixed water surface height ;3 Dynamic water surface height

*** The distance of the pile point on the left of the center point is negative , On the right is a positive value .

2.2 Data converted to other formats

Because the software that generates the profile is different , The requirements of the design unit are different , There are many formats of profile data , In order to submit measurement data to Party A , This program includes the conversion of several common formats .( The conversion of other formats is only a matter of reading and outputting text files , Peers with development ability can easily do )

3 The flow of programming

3.1 Create a location line selection set ： Go through the location line selection set

3.2 Use the positioning line to expand the outer frame (3 rice ) Create a section name selection set , Find and determine the section name of the location line

3.3 Use the positioning line to expand the outer frame (2 rice ) Create a spot elevation selection set , Move each elevation point vertically to the positioning line

3.4 Sort by the distance from the elevation point to the starting point of the location line

3.5 Sort all section lines by using the distance from the intersection of the locating line and the centerline to the starting point of the centerline

3.6 Output section data in sequence

4 Program interface

 5 Core source code

Option Explicit
Dim  Section name layer  As String,  Location line layer  As String
Dim  Spot elevation layer  As String,  Spot elevation type  As String
Dim  Watermark options  As Integer
Dim H0 As Double, Hn As Double, h1 As Double

Private Sub CommandButton1_Click()
Dim  Text block  As AcadSelectionSet,  Location line  As AcadSelectionSet
Dim  Center line  As AcadEntity, gcdObj As AcadEntity
Dim  The center line is long  As Double
Dim n As Integer, i As Integer
Dim objBlock As Variant
Dim FType(1) As Integer, FData(1)
Dim pts As Collection, pt(0 To 1) As Double
Dim pt1 As Variant, pt2 As Variant
Dim xyS As Variant, xyE As Variant
Dim  Section name  As String, m As String
Dim  Section lines (),  Number of lines  As Long
Dim Filename As String, mm As String
Dim  Water surface elevation  As Double
On Error Resume Next
       Location line layer  = ComboBox2.Text
     Section name layer  = ComboBox3.Text
       Spot elevation layer  = ComboBox4.Text
       Spot elevation type  = ComboBox1.Text
If OptionButton1.value = True Then
     Watermark options  = 0
End If
If OptionButton2.value = True Then
     Watermark options  = 1
    H0 = Val(TextBox1.Text)
End If
If OptionButton3.value = True Then
     Watermark options  = 2
    Dim cbFm() As String
    cbFm = Split(TextBox2.Text, "/", -1)
    H0 = Val(cbFm(0))
    Hn = Val(cbFm(1))
End If
      
 Extract profile data settings .Hide
    
ThisDrawing.Utility.GetEntity  Center line , xy, " Select the centerline object "
Filename = ThisDrawing.path & "\ Numerical axis section data .txt"
' Stations , Pile point elevation （ Point on longitudinal section ）, Water surface elevation 
' left ( The distance is negative — On the right side ( The distance is positive ) distance 1, Altitude 1, distance 2, Altitude 2,~, distance n, Altitude n
ThisDrawing.Utility.GetEntity  Center line , xy, " Select the centerline object "
 The center line is long  =  Center line .Length

ThisDrawing.SelectionSets.Item(" Through the selection set of points ").Delete
         Err.Clear
Set  Text block  = ThisDrawing.SelectionSets.Add(" Through the selection set of points ")
     
Dim sh As Double, SH1 As Double

ThisDrawing.Application.ZoomExtents
Set pts =  Polyline coordinate set ( Center line )

ThisDrawing.SelectionSets.Item(" Location line ").Delete
Err.Clear
Set  Location line  = ThisDrawing.SelectionSets.Add(" Location line ")      ' Location line object selection set 
        FType(0) = 8: FData(0) =  Location line layer 
        FType(1) = 0: FData(1) = "*LINE"
        filtertype = FType: filterdata = FData
 Location line .Select acSelectionSetAll, , , filtertype, filterdata
 Number of lines  = -1
' Organize section positioning line , Sort by the distance from the locating line to the starting point of the centerline .
For Each Entry In  Location line 
    If Entry.Handle =  Center line .Handle Then GoTo 50
    pt1 =  Center line .IntersectWith(Entry, acExtendNone)
    If UBound(pt1) < 0 Then GoTo 50
    Select Case Entry.ObjectName
          Case "AcDb2dPolyline", "AcDbPolyline"
               xyS = Entry.Coordinate(0)
               xyE = Entry.Coordinate(1)
          Case "AcDbLine"
               xyS = Entry.startPoint
               xyE = Entry.EndPoint
    End Select
    
     Number of lines  =  Number of lines  + 1
    ReDim Preserve  Section lines (3,  Number of lines )
     Section lines (0,  Number of lines ) =  distance _2P(pt1, xyS)                '0  The distance from the starting point of the positioning line to the midpoint 
     Section lines (1,  Number of lines ) =  Distance from point to starting point of point set (pts, pt1)    '1  The distance from the locating line to the starting point of the centerline , Used for hatch sorting 
     Section lines (2,  Number of lines ) = xyS                              '2  Starting point coordinates 
     Section lines (3,  Number of lines ) = xyE                              '3  Ordinate 
50:
Next
Call ArrayPaXu( Section lines , 0,  Number of lines , 1, True)
    
Open Filename For Output As #1
For n = 0 To  Number of lines 
    xyS =  Section lines (2, n)
    xyE =  Section lines (3, n)
    FType(0) = 8: FData(0) =  Section name layer 
    FType(1) = 0: FData(1) = "Text"
    Call  Two point expansion box (xyS, xyE, 3)   ' Expand on both sides  3  Meters are selected for the range   Section name   Annotation text 
     Text block .Clear
    filtertype = FType: filterdata = FData
     Text block .SelectByPolygon acSelectionSetCrossingPolygon, pl, filtertype, filterdata
     Section name  = Str( Section lines (1, n))
    For Each gcdObj In  Text block 
         Section name  = gcdObj.TextString
    Next
    
    Do While pts.count > 0
        pts.Remove index:=1
    Loop

    FType(0) = 8: FData(0) =  Spot elevation layer 
    FType(1) = 0: FData(1) =  Spot elevation type 
    
    Call  Two point expansion box (xyS, xyE, 2)   ' Expand on both sides  2  Select the elevation block of the exhibition point for the range of meters 
     Text block .Clear
    filtertype = FType: filterdata = FData
     Text block .SelectByPolygon acSelectionSetCrossingPolygon, pl, filtertype, filterdata
    Debug.Print  Section name ,  Text block .count
    For Each gcdObj In  Text block 
        pt1 = gcdObj.insertionPoint
        pt2 =  The point is perpendicular to the line (xyS, xyE, pt1)
        
        xy1(0) = pt2(0): xy1(1) = pt2(1)
        gcdObj.insertionPoint = xy1    ' The elevation point is moved vertically to the positioning line 
        Select Case gcdObj.ObjectName
            Case "AcDbText"
                 m = gcdObj.TextString
            Case "AcDbBlockReference"
                 objBlock = gcdObj.GetAttributes
                 m = objBlock(0).TextString
        End Select
        pt(0) =  distance _2P(xyS, pt2) -  Section lines (0, n)
        pt(1) = Val(m)
        
        For i = 1 To pts.count
            pt1 = pts(i)
            If pt(0) < pt1(0) Then
                pts.Add Item:=pt, Before:=i
                GoTo 60
            End If
        Next
        pts.Add Item:=pt
60: Next
    Dim  Elevation of middle stake point  As Double
    Dim s1 As Double, h1 As Double
    Dim s2 As Double, h2 As Double
    For i = 1 To pts.count
        pt1 = pts(i)
        If pt1(0) > 0 Then
            pt2 = pts(i - 1)
            s1 = Abs(pt2(0)): h1 = pt2(1)
            s2 = pt1(0): h2 = pt1(1)
             Elevation of middle stake point  = h1 + s1 * (h2 - h1) / (s1 + s2)
            Exit For
        End If
    Next
       
    Select Case  Watermark options 
           Case 0   ' No water surface elevation 
                 Water surface elevation  = "-1000"
           Case 1   ' Fixed water surface elevation 
                 Water surface elevation  = H0
           Case 2   ' Dynamic water surface elevation 
                 Water surface elevation  = H0 +  Section lines (1, n) * (Hn - H0) /  The center line is long 
    End Select
    
    Print #1,  Section name  + "," + Format( Elevation of middle stake point , "0.00") + "," + Format( Water surface elevation , "0.00")
    Print #1,  Point set to long string (pts)
Next
Close
 Text block .Delete
 Location line .Delete
MsgBox " congratulations , It's done ！"
Unload Me
End Sub

Private Sub CommandButton2_Click()
Dim WshShell As Object, Filename As String
Set WshShell = CreateObject("WScript.Shell")
Filename = VBApath + "\ Section data format .txt"
WshShell.Run "Notepad " & Filename
Set WshShell = Nothing
End Sub


Private Sub UserForm_Initialize()
Dim i As Integer, l1 As Integer, l2 As Integer, l3 As Integer
    ' Spot elevation type 
    ComboBox1.AddItem "INSERT"
    ComboBox1.AddItem "Text"
    ComboBox1.ListIndex = 0
    Dim newlayer As AcadLayer
    i = 0
    For Each newlayer In ThisDrawing.Layers
        l1 = IIf(newlayer.Name = "SZ-ZH-DIM" Or newlayer.Name = "Pile- Under wear 2" Or newlayer.Name = " Location line ", i, l1)
        l2 = IIf(newlayer.Name = "SZ-ZH-DIM" Or newlayer.Name = "Pile- Under wear 2" Or newlayer.Name = " Section name ", i, l2)
        l3 = IIf(newlayer.Name = "GCD", i, l3)
        ComboBox2.AddItem newlayer.Name  ' Location line layer name 
        ComboBox3.AddItem newlayer.Name  ' Section name layer name 
        ComboBox4.AddItem newlayer.Name  ' Elevation point layer name 
        i = i + 1
    Next newlayer
    ComboBox2.ListIndex = l1
    ComboBox3.ListIndex = l2
    ComboBox4.ListIndex = l3
    
    ComboBox6.AddItem " Nanjing jieying "   ' The double winged comma is vertically and horizontally integrated 
    ComboBox6.AddItem " Double winged space "
    ComboBox6.AddItem "Excel surface "
    ComboBox6.AddItem "Cass Format "
    ComboBox6.ListIndex = 0
End Sub

Private Sub CommandButton3_Click()
Dim Filename As String,  cross FileName As String,  longitudinal FileName As String
Dim strm() As String, pmxx() As String
Dim path As String, mm As String
Dim i As Integer
On Error Resume Next
Open VBApath & "path.txt" For Input As #1
    Input #1, path
Close
Filename = GetOpenFile(" Find the number axis format profile data file ", " text file  Files(*.txt), Profile.hdm", path)
If Filename = "" Then Exit Sub
strm = Split(Filename, "\", -1)
ReDim Preserve strm(UBound(strm) - 1)
path = Join(strm, "\")

Select Case ComboBox6.Text
       Case " Nanjing jieying "     ' Stations , distance 1, Altitude 1,....... distance n, Altitude n<>
            cross FileName = path & "\NJJYpm.txt"
           Open Filename For Input As #1
           Open  cross FileName For Output As #2
           While Not (EOF(1))
               Line Input #1, mm
               strm = Split(LTrim(mm), ",", -1)
               path = strm(0)
               Line Input #1, mm
               pl =  Long string to array (mm)
               Dim  The distance  As Double
                The distance  = pl(0)
               For i = 0 To UBound(pl) Step 2
                   pl(i) = pl(i) -  The distance       ' Change the distance to the left positioning distance 
               Next
               Print #2, path + "," + RealArrayJoin(pl, ",", True, False) + "<>"
           Wend
           Close
                                              
       Case " Double winged space "
            cross FileName = path & "\hdx.txt"
            longitudinal FileName = path & "\dmx.txt"
           Open Filename For Input As #1
           Open  cross FileName For Output As #2
           Open  longitudinal FileName For Output As #3
           While Not (EOF(1))
               Line Input #1, mm
               strm = Split(LTrim(mm), ",", -1)
               Print #3, Str( Intercept distance (strm(0))) + "," + strm(1)
               
               Line Input #1, mm
               Dim  Left array () As Double,  Right array () As Double
               pl = CStringToRealArray(mm, ",",  Left array ,  Right array )
               Print #2, strm(0) + " " + RealArrayJoin( Left array , " ", False, True)    ' reverse , Take the absolute value 
               Print #2, RealArrayJoin( Right array , " ", True, False)   ' Consequent , Do not take the absolute value 
           Wend
           Close
           
       Case "Excel surface "  ' Number axis data sequence 
            cross FileName = path & "\Profile.xlsx"
           Dim  That's ok  As Integer,  Column  As Integer, n As Integer
           Call  establish Excel file 
           If xlBook.Worksheets.count < 2 Then
               xlBook.Worksheets.Add
           End If
           xlBook.Worksheets(1).Name = " Cross section "
           xlBook.Worksheets(2).Name = " Longitudinal section "
           Set xlSheet = xlBook.Worksheets(2)
            Column  = 1: n = 0
           Open Filename For Input As #1
           While Not (EOF(1))
               With xlApp.Worksheets(" Cross section ")
                   Line Input #1, mm
                   strm = Split(LTrim(mm), ",", -1)
                   ' Longitudinal section data 
                   n = n + 1
                   xlSheet.Cells(n, 1) =  Intercept distance (strm(0))    '4  The distance from the locating line to the starting point of the centerline 
                   xlSheet.Cells(n, 2) = strm(1)              '3  Longitudinal section pile point ( Intersection of center line and section location line ) The elevation of the earth 
                    That's ok  = 1
                   .Cells( That's ok ,  Column ) = strm(0)         ' Section name 
                   .Cells( That's ok ,  Column  + 1) = strm(2)     ' Water surface elevation 
' The following create data validation 

                   With xlApp.Worksheets(" Cross section ").Range(.Cells(1,  Column  + 2), .Cells(1,  Column  + 2)).Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=" nothing , Altitude , Elevation difference "
                        .i
                   End With
                   .Cells(1,  Column  + 2) = " nothing "
                   Line Input #1, mm
                   strm = Split(LTrim(mm), ",", -1)
                   For i = 0 To UBound(strm) Step 2
                        That's ok  =  That's ok  + 1
                       .Cells( That's ok ,  Column ) = strm(i)          ' The distance from the pile point to the starting point of the locating line 
                       .Cells( That's ok ,  Column  + 1) = strm(i + 1)  ' Pile point elevation 
                   Next
                    Column  =  Column  + 3
               End With
           Wend
           Close
           xlBook.SaveAs ( cross FileName)
           xlBook.Close
           xlApp.Quit
           Set xlApp = Nothing
           Set xlBook = Nothing
       Case "Cass Format "
            cross FileName = path & "\hdm.hdm"
            longitudinal FileName = path & "\zdm.zdm"
           Open Filename For Input As #1
           Open  cross FileName For Output As #2
           Open  longitudinal FileName For Output As #3
           Print #3, "BEGIN, vertical section "
           While Not (EOF(1))
               Line Input #1, mm    ' Stations , Altitude , Water surface elevation 
               strm = Split(LTrim(mm), ",", -1)
               Print #3, Str( Intercept distance (strm(0))) + "," + strm(1)
               
               Print #2, "BEGIN," + strm(0)
               Line Input #1, mm
               strm = Split(LTrim(mm), ",", -1)
               For i = 0 To UBound(strm) Step 2
                   Print #2, strm(i) + "," + strm(i + 1)
               Next
           Wend
           Close
    End Select
    MsgBox " congratulations , It's done ！"
End Sub

Public Function  Point set to long string (pts As Collection) As String
Dim i As Integer
Dim mm As String
Dim pt As Variant
On Error Resume Next
pt = pts(1)
mm = Format(pt(0), "0.00") + "," + Format(pt(1), "0.00")
For i = 2 To pts.count
    pt = pts(i)
    mm = mm + "," + Format(pt(0), "0.00") + "," + Format(pt(1), "0.00")
Next
 Point set to long string  = mm
End Function

Public Function  Long string to array (mm As String) As Double()
Dim strm() As String, data() As Double, i As Integer
strm = Split(LTrim(mm), ",", -1)
ReDim data(UBound(strm))
For i = 0 To UBound(strm)
    data(i) = Val(strm(i))
Next
 Long string to array  = data
End Function

' Convert a long string to an array of real numbers ： Function returns an array of all elements , The left array returns elements with negative values on the left , The right array returns the elements with positive values on the right .
Public Function CStringToRealArray(mm As String,  Connector  As String,  Left array () As Double,  Right array () As Double) As Double()
Dim m() As String
Dim RealArray() As Double
Dim i As Integer, Left As Integer, Right As Integer
m = Split(mm,  Connector , -1)
ReDim RealArray(UBound(m))
For i = 0 To UBound(m) Step 2
    RealArray(i) = Val(m(i))
    RealArray(i + 1) = Val(m(i + 1))
    If RealArray(i) < 0 Then
        ReDim Preserve  Left array (Left + 1)
         Left array (Left) = RealArray(i)
         Left array (Left + 1) = RealArray(i + 1)
        Left = Left + 2
    Else
        ReDim Preserve  Right array (Right + 1)
         Right array (Right) = RealArray(i)
         Right array (Right + 1) = RealArray(i + 1)
        Right = Right + 2
    End If
Next
CStringToRealArray = RealArray
End Function

' real array （ Every two elements are a group , Such as ： distance 1, Altitude 1, distance 2, Altitude 2......） Convert to long string 
' Direction =false when , The order of points is reversed 
' The absolute value =true All distances are taken as absolute values ,
Public Function RealArrayJoin(RealArray() As Double,  Connector  As String,  Direction  As Boolean,  The absolute value  As Boolean) As String
Dim strm() As String, i As Integer
ReDim strm(UBound(RealArray))
If  Direction  = True Then
    For i = 0 To UBound(RealArray) Step 2
        strm(i) = IIf( The absolute value  = True, Str(Abs(RealArray(i))), Str(RealArray(i)))
        strm(i + 1) = Str(RealArray(i + 1))
    Next
Else
    Dim r As Integer
    For i = UBound(RealArray) To 0 Step -2
        strm(r) = IIf( The absolute value  = True, Str(Abs(RealArray(i - 1))), Str(RealArray(i - 1)))
        strm(r + 1) = Str(RealArray(i))
        r = r + 2
    Next
End If
RealArrayJoin = Join(strm,  Connector )
End Function

' Take out the numerical part of the station , As the distance of the longitudinal section 
Function  Analysis title (mm As String,  Water surface elevation  As Double,  distance  As Double,  Pile point elevation  As Double) As String
Dim strm() As String
On Error Resume Next
strm = Split(LTrim(mm), ",", -1)
 Water surface elevation  = Val(strm(2))
 Pile point elevation  = Val(strm(1))
 distance  =  Intercept distance (strm(0))
 Analysis title  = strm(0)
End Function


Function  Intercept distance (mm As String) As Double
Dim m As String, i As Integer, j As Integer
On Error Resume Next
j = Len(mm)
If IsNumeric(Right(mm, j - 1)) = True Then
     Intercept distance  = Val(Right(mm, j - 1))
    Exit Function
End If
i = InStr(mm, "+")
If i > 0 Then m = Mid(mm, i + 1, j - i)
i = InStr(mm, "-")
If i > 0 Then m = Mid(mm, i + 1, j - i)
 Intercept distance  = 1000 * Val(Mid(mm, 2, 1)) + Val(m)
End Function

Public Function  Polyline coordinate set (Eobj As AcadEntity) As Collection
Dim i As Integer, j As Integer
Dim pts As New Collection
Dim pt(0 To 2) As Double
xy = Eobj.Coordinates
r = IIf(Eobj.ObjectName = "AcDbPolyline", 2, 3)
For i = 0 To UBound(xy) Step r
    pt(0) = xy(i): pt(1) = xy(i + 1): pt(2) = 0
    pts.Add pt
Next
Set  Polyline coordinate set  = pts
End Function


Public Function  Distance from point to starting point of point set (pts As Collection, Point As Variant) As Double
Dim i As Integer, r As Integer
Dim pt1 As Variant, pt2 As Variant
Dim S As Double
For i = 1 To pts.count
    r = IIf(i = pts.count, 1, i + 1)
    pt1 = pts.Item(i)
    pt2 = pts.Item(r)
    If  The point is in the middle of the line (pt1, pt2, Point) = True Then
         Distance from point to starting point of point set  = S +  distance _2P(pt1, Point)
        Exit Function
    End If
    S = S +  distance _2P(pt1, pt2)
Next
 Distance from point to starting point of point set  = -1
End Function

Function  distance _2P(ByVal Axy As Variant, ByVal Bxy As Variant) As Double
Dim X As Double, Y As Double, Z As Double
X = Bxy(0) - Axy(0): Y = Bxy(1) - Axy(1)
If UBound(Axy) = 2 And UBound(Bxy) = 2 Then
    Z = Bxy(2) - Axy(2)
Else
    Z = 0
End If
 distance _2P = Sqr(X ^ 2 + Y ^ 2 + Z ^ 2)
End Function

Public Function  The point is perpendicular to the line (xyA As Variant, xyB As Variant, xyc As Variant) As Double()
     'xya  Is the starting point of the line ,xyb  Is the end of the straight line ,xyc  For the third point ,XYd  Is the return point coordinate 
Dim Qa As Double, qb As Double, xabc(0 To 1) As Double
     If Abs((xyB(0) - xyA(0))) < 0.000001 Then
        xabc(0) = xyA(0)
        xabc(1) = xyc(1)
     Else
        Qa = (xyB(1) - xyA(1)) / (xyB(0) - xyA(0))
        qb = xyc(0) / Qa + Qa * xyA(0) - xyA(1) + xyc(1)
        xabc(0) = (xyc(0) / Qa + Qa * xyA(0) - xyA(1) + xyc(1)) / (Qa + 1 / Qa)
        xabc(1) = Qa * xabc(0) - Qa * xyA(0) + xyA(1)
     End If
      The point is perpendicular to the line  = xabc
End Function

Public Sub ArrayPaXu(ArrayB As Variant, starRow As Long, endRow As Long, KeyColumn As Integer, Order As Boolean)
'         Array sorting       Array                Start line              Terminate line            Close the column                 In ascending order 
Dim i As Long, j As Long, n As Integer, APM As Variant                  'Currency
Dim bm As Variant, Ffm As Boolean
Ffm = IsNumeric(ArrayB(KeyColumn, starRow))     ' Is it a number 
For i = starRow To endRow
    For j = starRow To endRow - 1
         Select Case Ffm
                Case True      ' Numbers 
                     If Val(ArrayB(KeyColumn, j)) = Val(ArrayB(KeyColumn, j + 1)) Then GoTo 100
                     APM = IIf(Val(ArrayB(KeyColumn, j)) < Val(ArrayB(KeyColumn, j + 1)), -1, 1)
                Case False     ' character string 
                     APM = StrComp(ArrayB(KeyColumn, j), ArrayB(KeyColumn, j + 1), 1)
                     If APM = Null Or APM = 0 Then GoTo 100
         End Select
         Select Case Order
                Case True    ' Ascending 
                     If APM = -1 Then GoTo 100
                Case False   ' Descending 
                     If APM = 1 Then GoTo 100
         End Select
         For n = LBound(ArrayB) To UBound(ArrayB)
             bm = ArrayB(n, j)
             ArrayB(n, j) = ArrayB(n, j + 1)
             ArrayB(n, j + 1) = bm
         Next n
100: Next j
Next i
End Sub