Question

我的这张工作表包含大约100万行和3个表，这些表具有相同的标题（10列单元格），接下来的10列中的数据是未排序的。我的想法是，我希望VBA宏代码将1个表复制到新的工作簿工作表中，并将其他2个表排序。我尝试使用if语句，但是excel停止响应。有人可以帮我吗？

Src

   H1...H10 V1...V10 | H1...H10 V1...V10 | H1...H10 V1...V10
    x....x  1.....x  |  z....z  1.....z  |  k....k  1.....k
    y....y  1.....y  |  k....k  1.....k  |  z....z  1.....z
    k....k  1.....k  |  y....y  1.....y  |  x....x  1.....x
    z....z  1.....z  |  x....x  1.....x  |  y....y  1.....y

目的地

    H1...H10 V1...V10 | V1...V10  |  V1...V10
     x....x  1.....x  |  1.....x  |  1.....x
     y....y  1.....y  |  1.....y  |  1.....y
     k....k  1.....k  |  1.....k  |  1.....k
     z....z  1.....z  |  1.....z  |  1.....z

我的循环部分代码如下：

        k = Dest.Range("A" & Rows.Count).End(xlUp).Row + 1
        Dest.Range(Dest.Cells(2, 1), Dest.Cells(k, 62)).Clear
        n = Src.Range("A" & Rows.Count).End(xlUp).Row + 1
          For i = 2 To Src.Range("A" & Rows.Count).End(xlUp).Row
                  Dest.Range(Dest.Cells(a, 1), Dest.Cells(a, 20)).Value = 
                        Src.Range(Src.Cells(i, 1), Src.Cells(i, 20)).Value
          Next i

          For i = 2 To Src.Range("V" & Rows.Count).End(xlUp).Row
              For j = 2 To Dest.Range("A" & Rows.Count).End(xlUp).Row
                 If Src.Cells(i, 22).Value = Dest.Cells(j, 1).Value And _
                    Src.Cells(i, 24).Value = Dest.Cells(j, 3).Value And _
                    Src.Cells(i, 25).Value = Dest.Cells(j, 4).Value And _
                    Src.Cells(i, 26).Value = Dest.Cells(j, 5).Value Then
                    Dest.Range(Dest.Cells(j, 22), Dest.Cells(j, 35)).Value = Src.Range(Src.Cells(i, 28), Src.Cells(i, 41)).Value
                 End If

              Next j
          Next i

          For i = 2 To Src.Range("AQ" & Rows.Count).End(xlUp).Row
           For j = 2 To Dest.Range("A" & Rows.Count).End(xlUp).Row
               If Src.Cells(i, 43).Value = Dest.Cells(j, 1).Value And _
                  Src.Cells(i, 45).Value = Dest.Cells(j, 3).Value And _
                  Src.Cells(i, 46).Value = Dest.Cells(j, 4).Value And _
                  Src.Cells(i, 47).Value = Dest.Cells(j, 5).Value Then
                     Dest.Range(Dest.Cells(j, 37), Dest.Cells(j, 50)).Value = Src.Range(Src.Cells(i, 49), Src.Cells(i, 62)).Value
            End If
          Next  j
         Next i

Answer 1

正如我在评论中所说，您问题中的代码包含阻止其运行的错误。考虑：

Dest.Range(Dest.Cells(a, 1), Dest.Cells(a, 20)).Value = 
           Src.Range(Src.Cells(i, 1), Src.Cells(i, 20)).Value

由于第一行的末尾没有连续行字符，因此这些行会产生语法错误。您需要：

Dest.Range(Dest.Cells(a, 1), Dest.Cells(a, 20)).Value = _
           Src.Range(Src.Cells(i, 1), Src.Cells(i, 20)).Value

考虑：

For i = 2 To Src.Range("A" & Rows.Count).End(xlUp).Row
  Dest.Range(Dest.Cells(a, 1), Dest.Cells(a, 20)).Value = _
                    Src.Range(Src.Cells(i, 1), Src.Cells(i, 20)).Value
 Next i

a未在您发布的代码中初始化。如果运行此代码，则会得到“应用程序定义的错误或对象定义的错误”，因为a的默认值为零，并且不存在第0行。如果添加了a = 2，则源表1被复制到目标工作表的第2行，因为a没有进入循环。如果在循环中添加a = a + 1，则代码可以运行，但速度很慢。

由于可能随时触发的后台活动数量众多，因此对VBA例程进行定时很难。我对10,000和30,000行的计时表明，此副本的运行速度为每1,000行约.15秒，而对于一百万行而言，则约为150秒。添加Application.ScreenUpdating = False会减少运行时间，但只会减少一点。

代替逐行复制，可以一次复制整个块。您为每一行使用Range.Value = Range.Value。您可以扩大范围以覆盖整个块。我更喜欢Range.Copy Destination:=Cell，因为只需要完全指定要复制的范围。进行此更改后，一百万行的运行时间减少到大约25秒。

我现阶段的代码如下。与您的代码有许多重要区别。

在我的代码中没有像k，n，i，a这样的变量名。在编写代码时可能会记住这些变量是什么，但是在六个月或十二个月后返回此代码时，您是否还记得呢？更糟糕的是，您要其他人查看这些名称毫无意义的代码。我有一个命名变量的系统，如果代码不明显，我将对其进行解释。您可能不喜欢我的系统。很好，请与您的同事协商后自行决定。我可以看一下我和同事几年前写的代码，知道所有变量是什么。我的名字比您的名字长得多，但是每条语句都易于理解，从而减轻了键入我的名字的麻烦。

我不包括1和20这样的文字作为列号。我看到太多的工作表随时间而变化。这里有一个额外的列，在那里交换了列，依此类推。浏览代码试图确定哪些文字是要更改的列号以及哪些用于其他目的是一场噩梦。如果表曾移动或更改了大小，使用ColTbl1Start和ColTbl1End之类的名称将使更新代码变得容易。它们还使代码更易于阅读；什么是20、22和“ AV”？

我不清除工作表“目标”中的已用行；我删除了工作表中的每一行，这很容易。

您使用End(xlUp)查找列中最后使用的行。当您确信特定列的每一行都有一个值时，这是查找最后使用的行的最简单方法。如果不存在这样的列，那么您会遇到问题，因为尽管有几种查找最后一行或最后一列的技术，但在每种情况下都没有一种技术可以工作。几年前，我决定编写一个例程，该例程始终可以找到工作表的最后一行和最后一列。我已经在代码中加入了FindLastRowCol。

Option Explicit

  Const ColTbl1Start As Long = 1
  Const ColTbl1End As Long = 20

Sub Test()

  Dim a As Long
  Dim ColSrcLast As Long
  Dim Dest As Worksheet
  Dim I As Long
  Dim RowSrcLast As Long
  Dim Src As Worksheet

  Application.ScreenUpdating = False

  Set Src = Worksheets("Source")
  Set Dest = Worksheets("Destination")

  Dest.Cells.EntireRow.Delete

  Call FindLastRowCol(Src, RowSrcLast, ColSrcLast)

  With Src
    .Range(.Cells(1, ColTbl1Start), .Cells(RowSrcLast, ColTbl1End)).Copy Destination:=Dest.Cells(1, 1)
  End With

  Application.ScreenUpdating = True

End Sub
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
                          ByRef ColLast As Long)

  ' Sets RowLast and ColLast to the last row and column with a value
  ' in worksheet Wsht

  ' The motivation for coding this routine was the discovery that Find by
  ' previous row found a cell formatted as Merge and Center but Find by
  ' previous column did not. I had known that Find would miss merged
  ' cells but this was new to me.

  '   Dec16  Coded
  ' 31Dec16  Corrected handling of UserRange
  ' 15Feb17  SpecialCells was giving a higher row number than Find for
  '          no reason I could determine.  Added code to check for a
  '          value on rows and columns above those returned by Find
  ' 25Jun17  Found column with value above that found by Find. Fixed.

  Dim ColCrnt As Long
  Dim ColLastFind As Long
  Dim ColLastOther As Long
  Dim ColLastTemp As Long
  Dim ColLeft As Long
  Dim ColRight As Long
  Dim Rng As Range
  Dim RowIncludesMerged As Boolean
  Dim RowBot As Long
  Dim RowCrnt As Long
  Dim RowLastFind As Long
  Dim RowLastOther As Long
  Dim RowLastTemp As Long
  Dim RowTop As Long

  With Wsht

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      RowLastFind = 0
      ColLastFind = 0
    Else
      RowLastFind = Rng.Row
      ColLastFind = Rng.Column
    End If

    Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
    If Rng Is Nothing Then
    Else
      If RowLastFind < Rng.Row Then
        RowLastFind = Rng.Row
      End If
      If ColLastFind < Rng.Column Then
        ColLastFind = Rng.Column
      End If
    End If

    Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      RowLastOther = 0
      ColLastOther = 0
    Else
      RowLastOther = Rng.Row
      ColLastOther = Rng.Column
    End If

    Set Rng = .UsedRange
    If Rng Is Nothing Then
    Else
      If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
        RowLastOther = Rng.Row + Rng.Rows.Count - 1
      End If
      If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
        ColLastOther = Rng.Column + Rng.Columns.Count - 1
      End If
    End If

    If RowLastFind < RowLastOther Then
      ' Higher row found by SpecialCells or UserRange
      Do While RowLastOther > RowLastFind
        ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
        If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
          Debug.Assert False
          ' Is this possible
          ' Row after RowLastFind has value
          RowLastFind = RowLastOther
          Exit Do
        End If
        RowLastOther = RowLastOther - 1
      Loop
    ElseIf RowLastFind > RowLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    RowLast = RowLastFind

    If ColLastFind < ColLastOther Then
      ' Higher column found by SpecialCells or UserRange
      Do While ColLastOther > ColLastFind
        RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
        If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
          'Debug.Assert False
          ' Column after ColLastFind has value
          ' Possible causes:
          '   * Find does not recognise merged cells
          '   ' Find does not examine hidden cells
          ColLastFind = ColLastOther
          Exit Do
        End If
        ColLastOther = ColLastOther - 1
      Loop
    ElseIf ColLastFind > ColLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    ColLast = ColLastFind

  End With

End Sub

以上代码仅替换代码的第一部分。它将表1从工作表源复制到工作表目标。

您要合并到表2和3中的代码会非常慢。我的猜测是，要合并到包含一百万行的表中需要花费几天的时间。我可以建议稍作改进，但实际上您需要一种完全不同的方法。

我有很多想法可以尝试。我的目标是明天发布其余答案。

Answer 2

答案2，第2部分

我在第一个回答中告诉您，我不喜欢代码中的文字。我不想将第2行作为第一个数据行，因为有一个标题行。我不想将第5列引用为列号，因为当前是日期列。部分原因是行和列移动并且浏览代码试图确定2和5分别是行和列编号是一场噩梦。但是主要是因为我认为它使代码更易于阅读。在我较早的答案中，我使用了诸如RowSrcDataFirst或ColDate之类的常量。我在新代码中使用了一些常量，但是我需要数组，因此我可以以Property(InxTable)的形式访问表属性。没有数组常量，所以我有一个例程可以初始化这些数组。常量和例程在模块“ ModGlobal”中：

Option Explicit

  ' Colours for the V tables within destination worksheet
  Public ClrVTbls() As Variant

  ' Start and end columns for tables within destination worksheet
  ' There is one H table and then one V table per table in source worksheet
  ' These arrays are Long because there values are calculated
  Public ColDestHTblEnd As Long
  Public ColDestHTblStart As Long
  Public ColDestVTblsEnd() As Long
  Public ColDestVTblsStart() As Long

  ' Start and end columns for tables within source worksheet
  ' Each table has 10 H columns followed by 10 V columns
  ' These arrays are Variant because they are loaded using VBA.Array
  Public ColSrcTblsEnd() As Variant
  Public ColSrcTblsStart() As Variant
  Public ColSrcHTblsEnd() As Variant
  Public ColSrcHTblsStart() As Variant
  Public ColSrcVTblsEnd() As Variant
  Public ColSrcVTblsStart() As Variant

  Public Const InxTblMax As Long = 2     ' The tables are numbered zero to InxTblMax

  Public Const RowDestDataFirst As Long = 3
  Public Const RowSrcDataFirst As Long = 2

  Public Const WshtDestName As String = "Destination"
  Public Const WshtSrcName As String = "Source"

Sub LoadTblVariables()

  ' Load the global variables used to access the tables and the columns
  ' within them.

  ' The tables all have the same format and all require the same processing.
  ' Recording the start and end columns in arrays the same code can be used
  ' for all tables.

  ' If the tables ever change size or are moved, this routine MUST be changed
  ' to match.

  ' The arrays are loaded using VBA.Array which always sets the lower bound
  ' to zero.  In the code, The tables are numbered zero upwards to match the
  ' arrays.

  Dim InxTblCrnt As Long

  ' Load column numbers for tables within source worksheet
  ColSrcTblsStart = VBA.Array(1, 22, 43)    ' Start of each table
  ColSrcTblsEnd = VBA.Array(20, 41, 62)     ' End of each table
  ColSrcHTblsStart = VBA.Array(1, 22, 43)   ' Start of H columns for each table
  ColSrcHTblsEnd = VBA.Array(10, 31, 52)    ' End of H columns for each table
  ColSrcVTblsStart = VBA.Array(11, 32, 53)  ' Start of V columns for each table
  ColSrcVTblsEnd = VBA.Array(20, 41, 62)    ' End of V columns for each table

  ' If execution stops on one of these statements, the number of H columns is
  ' not the same in each table
  For InxTblCrnt = 1 To InxTblMax
  Debug.Assert ColSrcHTblsEnd(0) - ColSrcHTblsStart(0) = _
               ColSrcHTblsEnd(InxTblCrnt) - ColSrcHTblsStart(InxTblCrnt)
  Next

  ' Record position of H table within destination worksheet
  ColDestHTblStart = 1
  ColDestHTblEnd = ColDestHTblStart + ColSrcHTblsEnd(0) - ColSrcHTblsStart(0)

  ' Record position of V tables within destination worksheet
  ' Note that the code does not require the V tables be the same width
  ReDim ColDestVTblsStart(0 To InxTblMax)
  ReDim ColDestVTblsEnd(0 To InxTblMax)
  ColDestVTblsStart(0) = ColDestHTblEnd + 1
  ColDestVTblsEnd(0) = ColDestVTblsStart(0) + ColSrcVTblsEnd(0) - ColSrcVTblsStart(0)
  For InxTblCrnt = 1 To InxTblMax
    ColDestVTblsStart(InxTblCrnt) = ColDestVTblsEnd(InxTblCrnt - 1) + 1
    ColDestVTblsEnd(InxTblCrnt) = ColDestVTblsStart(InxTblCrnt) + _
                                  ColSrcVTblsEnd(InxTblCrnt) - _
                                  ColSrcVTblsStart(InxTblCrnt)
  Next

  ' Record colours for V tables within destination worksheet
  ClrVTbls = VBA.Array(RGB(226, 239, 218), RGB(255, 242, 204), RGB(221, 235, 247))

  'Debug.Print "Tables in source worksheet:"
  'For InxTblCrnt = 0 To InxTblMax
  '  Debug.Print "  Table " & InxTblCrnt + 1 & ": " & _
  '              ColNumToCode(ColSrcTblsStart(InxTblCrnt)) & " to " & _
  '              ColNumToCode(ColSrcTblsEnd(InxTblCrnt))
  'Next
  'Debug.Print "H Columns in source worksheet:"
  'For InxTblCrnt = 0 To InxTblMax
  '  Debug.Print "  Table " & InxTblCrnt + 1 & ": " & _
  '              ColNumToCode(ColSrcHTblsStart(InxTblCrnt)) & " to " & _
  '              ColNumToCode(ColSrcHTblsEnd(InxTblCrnt))
  'Next
  'Debug.Print "V Columns in source worksheet:"
  'For InxTblCrnt = 0 To InxTblMax
  '  Debug.Print "  Table " & InxTblCrnt + 1 & ": " & _
  '              ColNumToCode(ColSrcVTblsStart(InxTblCrnt)) & " to " & _
  '              ColNumToCode(ColSrcVTblsEnd(InxTblCrnt))
  'Next
  'Debug.Print "H Table in destination worksheet:"
  'Debug.Print "  " & ColNumToCode(ColDestHTblStart) & " to " & _
  '                   ColNumToCode(ColDestHTblEnd)
  'Debug.Print "V Tables in destination worksheet:"
  'For InxTblCrnt = 0 To InxTblMax
  '  Debug.Print "  Table " & InxTblCrnt + 1 & ": " & _
  '              ColNumToCode(ColDestVTblsStart(InxTblCrnt)) & " to " & _
  '              ColNumToCode(ColDestVTblsEnd(InxTblCrnt))
  'Next

End Sub

“ ModGlobal”中唯一需要修改的常量是WshtDestName和WstSrcName。我已将工作表命名为“源”和“目标”。您需要对此进行更改。

最后，例程MergeTables在ModMergeTables模块中”：

Option Explicit
Sub MergeTables()

  Dim Chr0 As String
  Dim ColSrcCrnt As Long
  Dim ColSrcFirst As Long
  Dim ColSrcLast As Long
  Dim ColSrcSecond As Long
  Dim IndicesCrnt() As Long
  Dim IndicesAll() As Long
  Dim InxInxCrnt As Long
  Dim InxInxCrntByTbl() As Long
  Dim InxTblCrnt As Long
  Dim KeyCrnt As String
  Dim KeyEmpty As String
  Dim KeysCrnt() As String
  Dim KeysAll() As String
  Dim Rng As Range
  Dim RowDestCrnt As Long
  Dim RowSrcCrnt As Long
  Dim RowSrcLast As Long
  Dim SrcCellValues As Variant
  Dim StartTime As Single
  Dim WshtDest As Worksheet
  Dim WshtSrc As Worksheet

  StartTime = Timer

  Application.ScreenUpdating = False

  Load frmProgress
  With frmProgress
    .lblMsg.Caption = "Prepare to merge tables"
    .lblCountCrnt.Caption = ""
    .lblCountOf.Caption = ""
    .lblCountMax.Caption = ""
    .Show vbModeless
  End With
  DoEvents

  Set WshtSrc = Worksheets(WshtSrcName)
  Set WshtDest = Worksheets(WshtDestName)

  ' Load variables and arrays that provide easy access to the tables
  Call LoadTblVariables

  With WshtDest
    .Cells.EntireRow.Delete
    ' Row 1: Spaces over H columns   "Table 1 over its V columns "   Ditto for Table 2 and Table 3
    For InxTblCrnt = 0 To InxTblMax
      Set Rng = .Range(.Cells(1, ColDestVTblsStart(InxTblCrnt)), _
                       .Cells(1, ColDestVTblsEnd(InxTblCrnt)))
      Rng.Merge
      Rng.Value = "Table " & InxTblCrnt + 1
      Rng.HorizontalAlignment = xlCenter
    Next
  End With

  ' Row 2: H column headings   Table 1 V column headings   Ditto for table 2 and 3
  With WshtSrc
    ' H column headings
    Set Rng = .Range(.Cells(1, ColSrcHTblsStart(0)), _
                     .Cells(1, ColSrcHTblsEnd(0)))
    Rng.Copy Destination:=WshtDest.Cells(2, ColDestHTblStart)
    ' V column headings
    For InxTblCrnt = 0 To InxTblMax
      Set Rng = .Range(.Cells(1, ColSrcVTblsStart(InxTblCrnt)), _
                       .Cells(1, ColSrcVTblsEnd(InxTblCrnt)))
      Rng.Copy Destination:=WshtDest.Cells(2, ColDestVTblsStart(InxTblCrnt))
    Next
  End With

  With frmProgress
    .lblMsg.Caption = "Copy source worksheet to an array"
    .lblCountCrnt.Caption = ""
    .lblCountOf.Caption = ""
    .lblCountMax.Caption = ""
  End With
  DoEvents

  Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)

  With WshtSrc
    SrcCellValues = .Range(.Cells(1, 1), .Cells(RowSrcLast, ColSrcLast)).Value
    ' SrcCellValues has the same structure and bounds as the worksheet
  End With

  'For RowSrcCrnt = 1 To RowSrcLast
  '  For ColSrcCrnt = 1 To ColSrcLast
  '    Debug.Print SrcCellValues(RowSrcCrnt, ColSrcCrnt) & " ";
  '  Next
  '  Debug.Print
  'Next

  Chr0 = Chr$(0)
  ' Value of KeyCrnt if all the H columns are empty.
  KeyEmpty = String(ColSrcHTblsEnd(0) - ColSrcHTblsStart(0), Chr0)

  ReDim KeysAll(0 To InxTblMax, RowSrcDataFirst To RowSrcLast)
  ReDim IndicesAll(0 To InxTblMax, RowSrcDataFirst To RowSrcLast)

  For InxTblCrnt = 0 To InxTblMax

    With frmProgress
      .lblMsg.Caption = "Build key and index arrays for table " & InxTblCrnt + 1
      .lblCountCrnt = 0
      .lblCountOf = "of"
      .lblCountMax = RowSrcLast
    End With
    DoEvents

    ReDim KeysCrnt(RowSrcDataFirst To RowSrcLast)
    ReDim IndicesCrnt(RowSrcDataFirst To RowSrcLast)

    ColSrcFirst = ColSrcHTblsStart(InxTblCrnt)
    ColSrcSecond = ColSrcFirst + 1
    ColSrcLast = ColSrcHTblsEnd(InxTblCrnt)

    For RowSrcCrnt = RowSrcDataFirst To RowSrcLast
      KeyCrnt = SrcCellValues(RowSrcCrnt, ColSrcFirst)
      For ColSrcCrnt = ColSrcSecond To ColSrcLast
        ' Use of Chr0 (Chr$(0) as a separator ensures short fields come before
        ' long fields. For example, "ABC" & Chr0 comes before "ABCD" & Chr0
        KeyCrnt = KeyCrnt & Chr0 & SrcCellValues(RowSrcCrnt, ColSrcCrnt)
      Next

      If KeyCrnt = KeyEmpty Then
        ' Make empty rows easy to identify
        KeysCrnt(RowSrcCrnt) = ""
      Else
        KeysCrnt(RowSrcCrnt) = KeyCrnt
      End If
      IndicesCrnt(RowSrcCrnt) = RowSrcCrnt

      frmProgress.lblCountCrnt = RowSrcCrnt
      DoEvents

    Next RowSrcCrnt

    'Debug.Print "Unsorted indices and keys for table " & InxTblCrnt + 1
    'For RowSrcCrnt = RowSrcDataFirst To RowSrcLast
    '  Debug.Print PadL(IndicesCrnt(RowSrcCrnt), 6) & " " & KeysCrnt(RowSrcCrnt)
    'Next

    With frmProgress
      .lblMsg.Caption = "Sort key and index array for table " & InxTblCrnt + 1
      .lblCountCrnt = ""
      .lblCountOf = ""
      .lblCountMax = ""
    End With
    DoEvents

    Call QuickSortC(IndicesCrnt, KeysCrnt)

    'Debug.Print "Sorted indices and keys for table " & InxTblCrnt + 1
    'For InxInxCrnt = RowSrcDataFirst To RowSrcLast
    '  RowSrcCrnt = IndicesCrnt(InxInxCrnt)
    '  Debug.Print PadL(RowSrcCrnt, 6) & " " & KeysCrnt(RowSrcCrnt)
    'Next

    ' KeysCrnt and IndicesCrnt are in the format required by QuickSortC.
    ' Move contents to KeysAll and IndicesAll ready for later stages

    With frmProgress
      .lblMsg.Caption = "Move key and index array for table " & InxTblCrnt + 1
      .lblCountCrnt = 0
      .lblCountOf = "of"
      .lblCountMax = RowSrcLast
    End With
    DoEvents

    For RowSrcCrnt = RowSrcDataFirst To RowSrcLast

      KeysAll(InxTblCrnt, RowSrcCrnt) = KeysCrnt(RowSrcCrnt)
      IndicesAll(InxTblCrnt, RowSrcCrnt) = IndicesCrnt(RowSrcCrnt)

      frmProgress.lblCountCrnt = RowSrcCrnt
      DoEvents

    Next RowSrcCrnt

  Next InxTblCrnt

  'Debug.Print "Sorted keys and indices by table"
  'ReDim InxInxCrntByTbl(0 To InxTblCrnt)
  'For InxTblCrnt = 0 To InxTblMax
  '  ' Initialise InxInxCrntByTbl with row of first indexed key for each table.
  '  ' Note blank rows will have been sorted to top
  '  InxInxCrnt = RowSrcDataFirst
  '  Do While True
  '    If InxInxCrnt > RowSrcLast Then
  '      ' Should not be possible but table exhausted
  '      Exit Do
  '    End If
  '    RowSrcCrnt = IndicesAll(InxTblCrnt, InxInxCrnt)
  '    If KeysAll(InxTblCrnt, RowSrcCrnt) <> "" Then
  '      ' Key found
  '      Exit Do
  '    End If
  '    InxInxCrnt = InxInxCrnt + 1
  '  Loop
  '  InxInxCrntByTbl(InxTblCrnt) = InxInxCrnt
  'Next InxTblCrnt
  '
  '' Loop until all tables are exhausted
  'Do While True
  '  KeyCrnt = ""
  '  ' Find first table with an available key
  '  For InxTblCrnt = 0 To InxTblMax
  '   InxInxCrnt = InxInxCrntByTbl(InxTblCrnt)
  '   If InxInxCrnt > RowSrcLast Then
  '     ' The table exhausted.  Try next.
  '   Else
  '     KeyCrnt = KeysAll(InxTblCrnt, IndicesAll(InxTblCrnt, InxInxCrnt))
  '     Exit For
  '   End If
  '  Next
  '  If KeyCrnt = "" Then
  '    ' All tables exhausted
  '    Exit Do
  '  End If
  '  ' Look for an earlier key in remaining tables
  '  For InxTblCrnt = InxTblCrnt + 1 To InxTblMax
  '   InxInxCrnt = InxInxCrntByTbl(InxTblCrnt)
  '   If InxInxCrnt > RowSrcLast Then
  '     ' The table exhausted.  Try next.
  '   ElseIf KeyCrnt > KeysAll(InxTblCrnt, IndicesAll(InxTblCrnt, InxInxCrnt)) Then
  '     ' Earlier key found
  '     KeyCrnt = KeysAll(InxTblCrnt, IndicesAll(InxTblCrnt, InxInxCrnt))
  '   End If
  '  Next
  '  ' Have next key. Output row numbers for tables that contain this key
  '  Debug.Print KeyCrnt & "  ";
  '  For InxTblCrnt = 0 To InxTblMax
  '    InxInxCrnt = InxInxCrntByTbl(InxTblCrnt)
  '    If InxInxCrnt > RowSrcLast Then
  '      ' The table exhausted so cannot contain this key.
  '      Debug.Print Space(7);
  '    ElseIf KeyCrnt = KeysAll(InxTblCrnt, IndicesAll(InxTblCrnt, InxInxCrnt)) Then
  '      ' This table contains current key
  '      Debug.Print PadL(IndicesAll(InxTblCrnt, InxInxCrnt), 6) & " ";
  '      ' Step over used key ready for next loop
  '      InxInxCrntByTbl(InxTblCrnt) = InxInxCrntByTbl(InxTblCrnt) + 1
  '    Else
  '      ' This table not exhausted but does not contain this key
  '      Debug.Print Space(7);
  '    End If
  '  Next
  '  Debug.Print
  'Loop  ' until all tables are exhausted

  With frmProgress
    .lblMsg.Caption = "Build destination worksheet"
    .lblCountCrnt = 0
    .lblCountOf = "of"
    .lblCountMax = RowSrcLast
  End With
  DoEvents

  ReDim InxInxCrntByTbl(0 To InxTblCrnt)
  RowDestCrnt = RowDestDataFirst

  For InxTblCrnt = 0 To InxTblMax
    ' Initialise InxInxCrntByTbl with row of first indexed key for each table.
    ' Note blank rows will have been sorted to top
    InxInxCrnt = RowSrcDataFirst
    Do While True
      If InxInxCrnt > RowSrcLast Then
        ' Should not be possible but table exhausted
        Exit Do
      End If
      RowSrcCrnt = IndicesAll(InxTblCrnt, InxInxCrnt)
      If KeysAll(InxTblCrnt, RowSrcCrnt) <> "" Then
        ' Key found
        Exit Do
      End If
      InxInxCrnt = InxInxCrnt + 1
    Loop
    InxInxCrntByTbl(InxTblCrnt) = InxInxCrnt
  Next InxTblCrnt

  ' Loop until all tables are exhausted
  Do While True
    KeyCrnt = ""
    ' Find first table with an available key
    For InxTblCrnt = 0 To InxTblMax
     InxInxCrnt = InxInxCrntByTbl(InxTblCrnt)
     If InxInxCrnt > RowSrcLast Then
       ' The table exhausted.  Try next.
     Else
       KeyCrnt = KeysAll(InxTblCrnt, IndicesAll(InxTblCrnt, InxInxCrnt))
       Exit For
     End If
    Next
    If KeyCrnt = "" Then
      ' All tables exhausted
      Exit Do
    End If
    ' Look for an earlier key in remaining tables
    For InxTblCrnt = InxTblCrnt + 1 To InxTblMax
     InxInxCrnt = InxInxCrntByTbl(InxTblCrnt)
     If InxInxCrnt > RowSrcLast Then
       ' The table exhausted.  Try next.
     ElseIf KeyCrnt > KeysAll(InxTblCrnt, IndicesAll(InxTblCrnt, InxInxCrnt)) Then
       ' Earlier key found
       KeyCrnt = KeysAll(InxTblCrnt, IndicesAll(InxTblCrnt, InxInxCrnt))
     End If
    Next
    ' Have next key. Output row for this key
    ' Find first source table for this key
    For InxTblCrnt = 0 To InxTblMax
     InxInxCrnt = InxInxCrntByTbl(InxTblCrnt)
     If InxInxCrnt > RowSrcLast Then
       ' The table exhausted.  Try next.
     Else
       RowSrcCrnt = IndicesAll(InxTblCrnt, InxInxCrnt)
       If KeyCrnt = KeysAll(InxTblCrnt, RowSrcCrnt) Then
         Exit For
       End If
     End If
    Next
    ' Copy H columns to destination worksheet
    With WshtSrc
      Set Rng = .Range(.Cells(RowSrcCrnt, ColSrcHTblsStart(InxTblCrnt)), _
                       .Cells(RowSrcCrnt, ColSrcHTblsEnd(InxTblCrnt)))
    End With
    Rng.Copy WshtDest.Cells(RowDestCrnt, ColDestHTblStart)
    ' Copy V columns to destination worksheet
    Do While True
      With WshtSrc
        Set Rng = .Range(.Cells(RowSrcCrnt, ColSrcVTblsStart(InxTblCrnt)), _
                         .Cells(RowSrcCrnt, ColSrcVTblsEnd(InxTblCrnt)))
      End With
      Rng.Copy WshtDest.Cells(RowDestCrnt, ColDestVTblsStart(InxTblCrnt))
      ' Step over used key ready for next loop
      InxInxCrntByTbl(InxTblCrnt) = InxInxCrntByTbl(InxTblCrnt) + 1
      InxTblCrnt = InxTblCrnt + 1
      If InxTblCrnt > InxTblMax Then
        Exit Do
      End If
      ' Find another table containing this key, if any
      Do While True
        InxInxCrnt = InxInxCrntByTbl(InxTblCrnt)
        If InxInxCrnt > RowSrcLast Then
          ' The table exhausted.  Try next if any.
        Else
          RowSrcCrnt = IndicesAll(InxTblCrnt, InxInxCrnt)
          If KeyCrnt = KeysAll(InxTblCrnt, RowSrcCrnt) Then
            'This table has V columns for this table
            Exit Do
          End If
        End If
        InxTblCrnt = InxTblCrnt + 1
        If InxTblCrnt > InxTblMax Then
          Exit Do
        End If
      Loop  ' until find another table for this key or no more tables
      If InxTblCrnt > InxTblMax Then
        Exit Do
      End If

    Loop  ' until no more tables for this row

    RowDestCrnt = RowDestCrnt + 1

    frmProgress.lblCountCrnt = InxInxCrntByTbl(0)
    DoEvents

  Loop  ' until all tables exhausted

    With frmProgress
      .lblMsg.Caption = "Finalise destination worksheet"
      .lblCountCrnt.Caption = ""
      .lblCountOf.Caption = ""
      .lblCountMax.Caption = ""
    End With
    DoEvents

  With WshtDest
    ' Colour V columns
    For InxTblCrnt = 0 To InxTblMax
      Set Rng = .Range(.Cells(1, ColDestVTblsStart(InxTblCrnt)), _
                       .Cells(1, ColDestVTblsEnd(InxTblCrnt))).EntireColumn
      Rng.Interior.Color = ClrVTbls(InxTblCrnt)
    Next
    ' Adjust column widths
    .Columns.AutoFit
  End With

  Unload frmProgress

  Debug.Print "Tables merged in " & Timer - StartTime & " seconds"

End Sub

我保留了在开发过程中使用的所有诊断代码，但已将其注释掉。您可能会发现取消注释该诊断代码并研究该代码的工作方式很有帮助。如果我的数据与您的数据不匹配，并且您必须研究为什么它不起作用，这将是至关重要的。

Answer 3

答案2。第1部分

答案2超出了Stack Overflow的字符数限制，因此我不得不将其分为两个。

不要太担心您的“草率”代码。没有一个人出生于了解VBA。尽管基本语言很简单，但数百种添加功能的库却不是。也许更糟的是，通常有几种方法可以达到相同的效果。对于您自己的代码，可以选择自己喜欢的代码，但是，如果您查看或借鉴他人的代码，则需要熟悉每种方法。成为VBA的好手，需要大量的练习，而根据我的经验，总会有很多东西需要学习。

这是一个全新的答案。如果您还没有研究原始答案，请对其进行研究，因为它包含对代码的第一部分的详细审查，相信会对您有所帮助。

我对您的代码的主要批评是缺乏设计。首先将表1移至目标工作表，这很容易。然后，您将表1中的每一行与表2中的每一行进行比较。每个比较都需要四个If。在考虑任何其他代码之前，即为四百万个Ifs。我从来没有尝试过对VBA语句的时间进行计时，因此我假设If花费了百万分之一秒，尽管这似乎非常乐观。如果这个假设是正确的，那么合并表1和表2将仅花费46天的时间。然后，合并表1和表3将需要另外46天。

我考虑的第一种方法是将三个表排序为一个。我很快放弃了这种方法，因为Excel不支持具有三百万行的工作表。

我考虑的下一个方法是将三个表分别按升序排序。然后，我将向下工作以查找最低键的表，将每个表中该键的行移至目标工作表，然后循环查找下一个最低键。我计划使用Excel的排序方式，因为我认为这会让您更容易理解。在记忆出致命缺陷之前，我以某种方式开发了这种方法。 If比较严格是Unicode，但Excel排序不是。如果您的值严格是字母或数字，Excel将按照您的期望进行排序。但是混合使用字母和数字值或包含标点符号，Excel排序就会变得古怪。您可以使用Excel排序，也可以使用“如果”，但不能在同一数据上同时使用两者。

我有一个VBA快速排序例程，该例程在需要严格的Unicode时使用。关于这个例程，我不再赘述，因为我相信它已被充分记录。切换到我的排序例程而不是Excel并不困难，但是当我的设计遇到问题时，我应该停下来重新思考。我的例程仅受内存限制，它应该能够对三百万行进行排序。我应该重新考虑我的原始方法。我从未尝试过合并三个表，它比合并两个表要复杂得多。恢复方法1是我将尝试的替代方法之一。

我希望我的方法有足够的背景知识，但如有必要，请再提出问题。

我不喜欢这样的例程：“这可能需要几分钟到几个小时的时间”，然后安静下来直到完成，所以我实施了进度表。我无法发布表格，因此您必须自己创建。这是我的表格：

确切的布局并不重要。该表单名为“ frmProgress”，标题为“ Progress merging table”。有四个都是标签的控件。此表格仅用于宏报告进度，没有输入控件。从上到下，从左到右，控件是“ lblMsg”，“ lblCountCrnt”，“ lblCountOf”和“ lblCountMax”。我表单中的标题只是为了辅助表单设计，它们在运行时都被覆盖。 “ lblCountMax”中的文本保持左对齐，但这不是必需的。如果您从未创建过用户表单，则搜索“ VBA创建用户表单”会弹出很多教程。

有可能在单个模块中包含以下所有代码。但是，我更喜欢划分代码，以便每个用途只有一个模块。

这些年来，我创建了标准的子例程和函数来执行我一次又一次的任务。我将Excel的“个人”工作簿用作库，因此可以从我的每个工作簿中访问它们。

我将此模块命名为“ LibOffice”，其中包含在Office中有用的例程：

Option Explicit
Function Median3(ByRef Indices() As Long, Keys() As String, _
                 ByVal InxLow As Long, ByVal InxHigh As Long) As Long

  ' In QuickSortA, the pivot would be the first or last
  ' value in the partition.  This gave good results unless the array
  ' was already sorted or reserve sorted.
  ' Selecting the mediam of the low, high and mid-value significantly
  ' reduced the duration of the sort in this situation.

  Dim InxIS As Long
  Dim IndicesSelected(1 To 3) As Long
  Dim IndexSave As Long

  If InxLow + 1 = InxHigh Then
    ' No mid-value.
    'Debug.Assert False
    Median3 = InxHigh
    Exit Function
  End If

  IndicesSelected(1) = InxLow
  IndicesSelected(2) = (InxLow + InxHigh) \ 2
  IndicesSelected(3) = InxHigh

  ' Sort elements of IndicesSelected into ascending value of referenced key
  InxIS = 1
  Do While InxIS < 3
    If Keys(Indices(IndicesSelected(InxIS))) > Keys(Indices(IndicesSelected(InxIS + 1))) Then
      ' Swap out of sequence entries
      'Debug.Assert False
      IndexSave = IndicesSelected(InxIS)
      IndicesSelected(InxIS) = IndicesSelected(InxIS + 1)
      IndicesSelected(InxIS + 1) = IndexSave
      If InxIS > 1 Then
        ' There is a previous entry so check entry
        ' moved back does not need to be moved further
        'Debug.Assert False
        InxIS = InxIS - 1
      Else
        ' At beginning of array so check next pair
        'Debug.Assert False
        InxIS = InxIS + 1
      End If
    Else
      ' This pair in correct sequence so check next pair.
      InxIS = InxIS + 1
    End If
  Loop

  Median3 = IndicesSelected(2)

End Function
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with leading PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Sep15 Coded
  ' 20Dec15 Added code so overlength strings are not truncated
  ' 10Jun16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadL = Str
  Else
    PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
  End If

End Function
Public Function PadR(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with trailing PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Nov15 Coded
  ' 15Sep16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadR = Str
  Else
    PadR = Left$(Str & String(PadLen, PadChr), PadLen)
  End If

End Function
Public Sub QuickSortC(ByRef Indices() As Long, ByRef Keys() As String)

  ' * On entry, Keys() contains the values by which the target array is to be sorted.
  ' * On entry, Indices(N) identifies the position within the target array of the
  '   entry represented by Keys(N).
  ' * On exit, Indices() will have been sorted so it references the entries in the target
  '   array in ascending sequence. That is, Indices(LBound(Indices)) is the first entry in
  '   the target array, Indices(LBound(Indices)+1) is the second entry in the target array
  '   and so on.  If descending sequence is required, read Indices in reverse sequence.
  ' * The "target array" can be an array, a collection, part of a worksheet or anything
  '   that has a sequence.  The values of the target array could be simple data types
  '   (long, string, etc) or user data types or objects.  The only restriction is that
  '   the value or part of the value of each element is, or can be converted to, a
  '   string whose value can be placed in Keys().  The values in Keys() and Indices()
  '   could represent the entire array, a range or a selection of elements.  It is the
  '   caller's responsibility to create Keys() and Indices() as required so QuickSort can
  '   create the desired sequence.

  ' * In Mar 2007, or perhaps earlier, I coded an implementation of the Shell Sort.
  '   That macro had the comparisons controlling the sort hard coded into the routine.
  '   Over time, I created versions to sort strings, numbers of various types and
  '   two-dimensional arrays. This was neither convenient nor efficient.
  ' * Other languages provide a simple interface to a consistent sort routine that
  '   allow different sort sequences of different data types. I wanted some of that
  '   convenience with a VBA sort.  I also wanted an implementation of Quick Sort which
  '   in most situations is faster than Shell Sort.
  ' * VBA versions of Quick Sort are available on the web but I could not find any
  '   that had the functionality I sought.
  ' * Passing the name of a comparison macro to QuickSort as a parameter and using
  '   Application.Run gave me the functionality I sought but was impossibly slow.
  ' * I tried other approaches which gave me the performation I wanted but not the
  '   the functional. Eventually I settled for making the caller responsible for
  '   creating Indices and Keys. Thid gave me good performation plus an approximation
  '   of the functionality I sought.

  ' Coded 2014 - 2016  No details recorded although I recall a lot of experimentation
  '                    with different techniques before settling for an index sort and
  '                    then discovery of an obscure error in the initial
  '                    implementation of the quick sort algorithm

  ' The arrays Indices and Keys must match.
  Debug.Assert LBound(Indices) = LBound(Keys)
  Debug.Assert UBound(Indices) = UBound(Keys)

  Dim InxHigh As Long        ' End of current partition
  Dim InxHighCrnt As Long    ' Search from end of partition for key that belongs after pivot
  Dim InxHighPrev            ' Value after previous swap
  Dim InxLow As Long         ' Start of current partition
  Dim InxLowCrnt As Long
  Dim InxLowPrev             ' Value after previous swap
  Dim InxPivot As Long       ' Search from start of partition for key that belongs before pivot
  Dim InxTemp As Long
  Dim Pivot As String
  Dim ToDoHigh As New Collection  '\ ToDoLow(N) to ToDoHigh(N) identifies
  Dim ToDoLow As New Collection   '/ a range to be partitioned.

  ToDoLow.Add LBound(Indices)
  ToDoHigh.Add UBound(Indices)

  ' Loop until every range to be partitioned has been extracted from ToDoLow
  ' and ToDoHigh and processed
  Do While ToDoLow.Count > 0

    ' Extract and remove next range to partition from collections ToDoLow and ToDoHigh
    InxLow = ToDoLow(ToDoLow.Count)
    InxHigh = ToDoHigh(ToDoHigh.Count)
    ToDoLow.Remove (ToDoLow.Count)
    ToDoHigh.Remove (ToDoHigh.Count)

    ' Initialise control indices
    InxPivot = Median3(Indices, Keys, InxLow, InxHigh)
    InxLowCrnt = InxLow - 1
    InxHighCrnt = InxHigh + 1

    Pivot = Keys(Indices(InxPivot))

    Do ' Until Index for searching from start crosses index searching from end

      Do ' Until find next element from start that belongs after Pivot
        InxLowCrnt = InxLowCrnt + 1
        If Pivot < Keys(Indices(InxLowCrnt)) Then
          Exit Do
        End If
        If InxLowCrnt = InxHigh Then
          Exit Do
        End If
      Loop

      Do  ' Until find next element from end that belongs before Pivot
        InxHighCrnt = InxHighCrnt - 1
        If Keys(Indices(InxHighCrnt)) < Pivot Then
          Exit Do
        End If
        If InxHighCrnt = InxLow Then
          Exit Do
        End If
      Loop

     If InxLowCrnt < InxHighCrnt Then
      ' Swap elements
      InxTemp = Indices(InxLowCrnt)
      Indices(InxLowCrnt) = Indices(InxHighCrnt)
      Indices(InxHighCrnt) = InxTemp
      InxLowPrev = InxLowCrnt
      InxHighPrev = InxHighCrnt
     End If

    Loop Until InxHighCrnt <= InxLowCrnt

    ' Final tidy.  Move pivot to its final position by swapping with last low or high
    If InxPivot < InxLowCrnt And InxPivot > InxHighCrnt Then
      ' Pivot is between InxLowCrnt and InxHighCrnt so is already in its final position
      ' Validate pivot it correctly positioned
      'If InxPivot > InxLow Then
      '  Debug.Assert Keys(Indices(InxPivot - 1)) <= Keys(Indices(InxPivot))
      'End If
      'If InxPivot < InxLow Then
      '  Debug.Assert Keys(Indices(InxPivot)) <= Keys(Indices(InxPivot + 1))
      'End If
    ElseIf InxPivot < InxLowCrnt Then
      ' Pivot is within the low half of the partition.
      ' InxHighCrnt is the highest entry with a value less than the pivot so swap
      ' pivot with it.
      Debug.Assert InxHighCrnt >= InxLow  ' Don't think InxHighCrnt can be below InxLow but check
      InxTemp = Indices(InxHighCrnt)
      Indices(InxHighCrnt) = Indices(InxPivot)
      Indices(InxPivot) = InxTemp
      InxPivot = InxHighCrnt   ' New position of pivot
      ' Validate pivot it correctly positioned
      'If InxPivot > InxLow Then
      '  Debug.Assert Keys(Indices(InxPivot - 1)) <= Keys(Indices(InxPivot))
      'End If
      'If InxPivot < InxLow Then
      '  Debug.Assert Keys(Indices(InxPivot)) <= Keys(Indices(InxPivot + 1))
      'End If
    Else
      ' Pivot is within the high half of the partition.
      ' InxLowCrnt is the lowest entry with a value greater than the pivot so swap
      ' pivot with it.
      Debug.Assert InxLowCrnt <= InxHigh  ' Don't think InxLowCrnt can be above InxHigh but check
      InxTemp = Indices(InxLowCrnt)
      Indices(InxLowCrnt) = Indices(InxPivot)
      Indices(InxPivot) = InxTemp
      InxPivot = InxLowCrnt   ' New position of pivot
      ' Validate pivot it correctly positioned
      'If InxPivot > InxLow Then
      '  Debug.Assert Keys(Indices(InxPivot - 1)) <= Keys(Indices(InxPivot))
      'End If
      'If InxPivot < InxLow Then
      '  Debug.Assert Keys(Indices(InxPivot)) <= Keys(Indices(InxPivot + 1))
      'End If
    End If

    ' The original algorithm used recursion. For VBA, the use
    ' of two collections is of the order of twice as fast.
    If InxPivot - 1 > InxLow Then
      ToDoLow.Add InxLow
      ToDoHigh.Add InxPivot - 1
    End If
    If InxHigh > InxPivot + 1 Then
      ToDoLow.Add InxPivot + 1
      ToDoHigh.Add InxHigh
     End If

  Loop  ' Until ToDoLow and ToDoHigh are empty

End Sub

我将此模块命名为“ LibExcel”，其中包含对Excel有用的例程：

Option Explicit
Public Function ColNumToCode(ByVal ColNum As Long) As String

  Dim ColCode As String
  Dim PartNum As Long

  ' 3Feb12  Adapted to handle three character codes.
  ' ??????  Renamed from ColCode to create a more helpful name

  If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    ColCode = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      ColCode = Chr(65 + PartNum) & ColCode
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

  ColNumToCode = ColCode

End Function
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
                          ByRef ColLast As Long)

  ' Sets RowLast and ColLast to the last row and column with a value
  ' in worksheet Wsht

  ' The motivation for coding this routine was the discovery that Find by
  ' previous row found a cell formatted as Merge and Center but Find by
  ' previous column did not. I had known that Find would miss merged
  ' cells but this was new to me.

  '   Dec16  Coded
  ' 31Dec16  Corrected handling of UserRange
  ' 15Feb17  SpecialCells was giving a higher row number than Find for
  '          no reason I could determine.  Added code to check for a
  '          value on rows and columns above those returned by Find
  ' 25Jun17  Found column with value above that found by Find. Fixed.

  Dim ColCrnt As Long
  Dim ColLastFind As Long
  Dim ColLastOther As Long
  Dim ColLastTemp As Long
  Dim ColLeft As Long
  Dim ColRight As Long
  Dim Rng As Range
  Dim RowIncludesMerged As Boolean
  Dim RowBot As Long
  Dim RowCrnt As Long
  Dim RowLastFind As Long
  Dim RowLastOther As Long
  Dim RowLastTemp As Long
  Dim RowTop As Long

  With Wsht

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      RowLastFind = 0
      ColLastFind = 0
    Else
      RowLastFind = Rng.Row
      ColLastFind = Rng.Column
    End If

    Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
    If Rng Is Nothing Then
    Else
      If RowLastFind < Rng.Row Then
        RowLastFind = Rng.Row
      End If
      If ColLastFind < Rng.Column Then
        ColLastFind = Rng.Column
      End If
    End If

    Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      RowLastOther = 0
      ColLastOther = 0
    Else
      RowLastOther = Rng.Row
      ColLastOther = Rng.Column
    End If

    Set Rng = .UsedRange
    If Rng Is Nothing Then
    Else
      If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
        RowLastOther = Rng.Row + Rng.Rows.Count - 1
      End If
      If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
        ColLastOther = Rng.Column + Rng.Columns.Count - 1
      End If
    End If

    If RowLastFind < RowLastOther Then
      ' Higher row found by SpecialCells or UserRange
      Do While RowLastOther > RowLastFind
        ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
        If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
          Debug.Assert False
          ' Is this possible
          ' Row after RowLastFind has value
          RowLastFind = RowLastOther
          Exit Do
        End If
        RowLastOther = RowLastOther - 1
      Loop
    ElseIf RowLastFind > RowLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    RowLast = RowLastFind

    If ColLastFind < ColLastOther Then
      ' Higher column found by SpecialCells or UserRange
      Do While ColLastOther > ColLastFind
        RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
        If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
          'Debug.Assert False
          ' Column after ColLastFind has value
          ' Possible causes:
          '   * Find does not recognise merged cells
          '   ' Find does not examine hidden cells
          ColLastFind = ColLastOther
          Exit Do
        End If
        ColLastOther = ColLastOther - 1
      Loop
    ElseIf ColLastFind > ColLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    ColLast = ColLastFind

  End With

End Sub

Answer 4

答案3

我创建比答案2更快的VBA代码的尝试失败。问题是：

With WshtSrc
  SrcCellValues = .Range(.Cells(1, 1), .Cells(RowSrcLast, ColSrcLast)).Value
End With

将整个工作表下载到内存可以加快访问工作表中单元格的代码。上面的代码起初可以正常工作，但是随着我的工作簿变得越来越大，包含更多的代码和更多的工作表，我遇到了“内存不足”的错误。我不得不停止下载工作表。直接访问单元会降低我的代码的速度，足以抵消使用更好技术实现的速度改进。

基于乐观的假设，您的原始代码将花费一百多天的时间。我将其减少到三天多一点。如果这是一项一次性的任务，则可能会使计算机长时间运行。如果这是一项常规任务，我认为Excel VBA不可行。

您不应在Excel中保留此数据量；您应该使用数据库。我认为甚至Access也会更好。一个将目标工作表输出到新工作簿的Access宏将使您拥有外观，并且由于处理量少得多，因此它应具有可接受的性能。

如果必须使用Excel来保存数据，建议使用VB。 VB替代了VBA。 VB语法与VBA相似，因此学习曲线不太陡。社区版本（足以满足您的需求）是免费的。人们会告诉您，VB到Excel的访问速度很慢，这是事实。每个单独的访问都很慢，但是我希望VB程序能够在几秒钟内下载整个源工作表并上传目标工作表。在下载和上传之间，VB处理比VBA处理快得多。我有一个客户正在尝试在VBA中进行复杂的计算。从一小部分计算得出，我估计总持续时间为43天。通过将代码移植到VB，我将持续时间缩短到52分钟。 VB几乎肯定会提供一种可行的解决方案，因此如果无法选择数据库，则应考虑使用它。

是否有使用VBA宏代码对表进行排序的快速方法？

4 个答案: