vba - 有一种方法可以在不使用内置排序功能的情况下对列进行排序？

Question

我非常希望 VBA 执行以下操作

1）剪切选定的行

2）按字母顺序将行插入正确的位置（基于col C）

我不能使用排序的原因是因为我有大量对一张纸的引用，当我使用排序时，它弄乱了所有引用，即使它们都有 $ 。我发现切割可以解决问题

Answer 1

我相信下面的宏满足您的要求。

常量ColSort定义了我设置为 C 的排序列。常量RowDataFirst定义了第一个数据行。我的测试数据有两个标题行。根据需要更改 的值RowDataFirst。

我只对一张测试工作表进行了排序，但我相信该宏适用于任意数量的行和列。

我从工作表“SortSrc”排序到“SortDest”。这些工作表的名称由常量WkShtNameDest和WkShtNameSrc. 根据需要更改这些常量。

我已经包含了一个 shell 排序的 VBA 实现。这不被认为是最好的排序，但我手头有例程，你不会对足够的数据进行排序。

它创建一个包含列 C 的值和行号的数组。我对这个索引数组进行排序。我使用排序索引数组来控制将数据从源工作表复制到目标。

我希望我已经包含了足够多的评论。如有必要，请回来提出问题。

Option Explicit
Sub SortByCutNPaste()

  Const ColSort As String = "C"
  Const RowDataFirst As Long = 3
  Const WkShtNameDest As String = "SortDest"
  Const WkShtNameSrc As String = "SortSrc"

  Dim ColMax As Long
  Dim InxSort As Long
  Dim SortArray() As String
  Dim RangeDest As Range
  Dim RangeSrc As Range
  Dim RowDestCrnt As Long
  Dim RowMax As Long
  Dim RowSrcCrnt As Long

  With Sheets(WkShtNameSrc)
    ' Find the maximum used row and maximum used column
    RowMax = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
    ColMax = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
  End With

  ' Size sort array so one entry per data row
  ReDim SortArray(1 To RowMax - RowDataFirst + 1)

  ' Build sort array with each entry containing:
  '   Value of column C     Nul     Row number padded to three digits

  ' The Nul is used as a low value in case any cell value ends in what looks
  ' like a row number.  For example:
  '   Row 1  Value ABC001
  '   Row 2  Value ABC
  ' would give sort keys ABC001001 and ABC002 which would be sorted incorrectly.
  ' Keys ABC001(0)001 and ABC(0)002 will sort incorrectly.

  ' Use LCase(.Cells(RowSrcCrnt, ColSort).Value) if you want a case insensitive sort.

  ' I have padded row numbers to three digits since you say you have 100 rows.

  InxSort = LBound(SortArray)
  With Sheets(WkShtNameSrc)
    For RowSrcCrnt = RowDataFirst To RowMax
      SortArray(InxSort) = .Cells(RowSrcCrnt, ColSort).Value & _
                           Chr(0) & Right("000" & RowSrcCrnt, 3)
      InxSort = InxSort + 1
    Next
  End With

  ' Sort array
  Call ShellSort(SortArray, UBound(SortArray))

  ' Prepare destination worksheet

  With Sheets(WkShtNameDest)
    ' Clear any existing contents
    .Cells.EntireRow.Delete
  End With

  ' Copy column widths
  With Sheets(WkShtNameSrc)
    .Rows(1).EntireRow.Copy
  End With
  With Sheets(WkShtNameDest)
    .Rows(1).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                          SkipBlanks:=False, Transpose:=False
  End With

'  For InxSort = LBound(SortArray) To UBound(SortArray)
'    Debug.Print SortArray(InxSort)
'  Next

  ' Copy heading rows from source to destination
  ' Note source and destination row numbers are the same
  ' so use RowSrcCrnt for both worksheets.
  For RowSrcCrnt = 1 To RowDataFirst - 1
    With Sheets(WkShtNameSrc)
      Set RangeSrc = .Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColMax))
    End With
    With Sheets(WkShtNameDest)
      Set RangeDest = .Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColMax))
    End With
    RangeSrc.Copy Destination:=RangeDest
  Next

  ' Copy data rows in index sequence
  RowDestCrnt = RowDataFirst
  For InxSort = LBound(SortArray) To UBound(SortArray)

    RowSrcCrnt = Val(Right(SortArray(InxSort), 3))
    With Sheets(WkShtNameSrc)
      Set RangeSrc = .Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColMax))
    End With
    With Sheets(WkShtNameDest)
      Set RangeDest = .Range(.Cells(RowDestCrnt, 1), .Cells(RowDestCrnt, ColMax))
    End With
    RangeSrc.Copy Destination:=RangeDest
    RowDestCrnt = RowDestCrnt + 1
  Next

End Sub
Public Sub ShellSort(ByRef arrstgTgt() As String, ByVal inxLastToSort As Integer)

  ' Converted by Tony Dallimore in 2005 from Pascal routine in "Algorithms"
  ' by Robert Sedgewick (2nd edition) published 1989 by Addison-Wesley.

  '   The most basic sort is the insertion sort in which adjacent elements are compared
  ' and swapped as necessary.  This can be very slow if the smallest elements are at
  ' end.  ShellSort is a simple extension which gains speed by allowing exchange of
  ' elements that are far apart.
  '   The idea is to rearrange the file to give it the property that taking every h-th
  ' element (starting anywhere) yields a sorted file.  Such a file is said to be
  ' h-sorted.  Put another way, an h-sorted file is h independent sorted files,
  ' interleaved together.  By h-sorting for large value of H, we can move elements
  ' in the array long distances and thus make it easier to h-sort for smaller values of
  ' h.  Using such a procedure for any sequence of values of h which ends in 1 will
  ' produce a sorted file.
  '   This program uses the increment sequence: ..., 1093, 364, 121, 40, 13, 4, 1.  This
  ' is known to be a good sequence but cannot be proved to be the best.
  '   The code looks faulty but it is not.  The inner loop compares an
  ' entry with the previous in the sequence and if necessary moves it back down the
  ' sequence to its correct position.  It does not continue with the rest of the sequence
  ' giving the impression it only partially sorts a sequence.  However, the code is not
  ' sorting one sequence then the next and so on.  It examines the entries in element
  ' number order.  Having compared an entry against the previous in its sequence, it will
  ' be intH loops before the next entry in the sequence in compared against it.

  ' arrstgTgt      The array to be sorted.
  ' inxLastToSort  Elements lbound(arrstgTgt) to inxLastToSort are to be sorted.

  Dim intNumRowsToSort          As Integer
  Dim intLBoundAdjust           As Integer
  Dim intH                      As Integer
  Dim inxRowA                   As Integer
  Dim inxRowB                   As Integer
  Dim inxRowC                   As Integer
  Dim stgTemp                   As String

  'Dim intComps                  As Integer
  'Dim intSwaps                  As Integer

  intNumRowsToSort = inxLastToSort - LBound(arrstgTgt) + 1
  intLBoundAdjust = LBound(arrstgTgt) - 1

  ' Set intH to 1, 4, 13, 40, 121, ..., 3n+1, ... until intH > intNumRowsToSort
  intH = 1
  Do While intH <= intNumRowsToSort
    intH = 3 * intH + 1
  Loop

  Do While True
    If intH = 1 Then Exit Do
    ' The minimum value on entry to this do-loop will be 4 so there is at least
    ' one repeat of the loop.
    intH = intH \ 3
    For inxRowA = intH + 1 To intNumRowsToSort
      stgTemp = arrstgTgt(inxRowA + intLBoundAdjust)
      inxRowB = inxRowA
      Do While True
        ' The value of element inxRowA has been saved.  Now move the element intH back
        ' from row inxRowA into this row if it is smaller than the saved value.  Repeat
        ' this for earlier elements until one is found that is larger than the saved
        ' value which is placed in the gap.
        inxRowC = inxRowB - intH
        If arrstgTgt(inxRowC + intLBoundAdjust) <= stgTemp Then Exit Do
        arrstgTgt(inxRowB + intLBoundAdjust) = arrstgTgt(inxRowC + intLBoundAdjust)
        inxRowB = inxRowC
        If inxRowB <= intH Then Exit Do
      Loop
      arrstgTgt(inxRowB + intLBoundAdjust) = stgTemp
    Next
  Loop

End Sub