Sorting Excel按数字排序宏

我使用宏删除报告中不包含数字的行

此宏查找关键路径号并将其拆分。在a1列中，删除列表中没有的数字

这个宏工作正常。除此之外，我想按关键路径编号顺序对a1列进行排序

我添加了我想要的和我的报告文件。报告文件底部有一个关键路径文本。单击Düzenle宏时，删除行，但不按关键路径编号顺序排序

---

谢谢你的帮助

我不喜欢同时执行复杂的更改和删除行。如果出现任何问题，您必须恢复工作表。我引入了一个新的工作表“关键路径”，并按所需顺序将工作表“Revit KBK Sonuç”中所需的所有内容复制到该工作表中

我已经在宏中描述了我正在做什么以及为什么。我希望一切都清楚，但如有必要，请询问

Option Explicit
Sub ertert()

  ' I avoid literals within the code if I think those literals may change
  ' over time and/or if I think a name would make the code clearer.
  Const ColLast As Long = 10
  Const ColShtHdrLast As Long = 2
  Const TableHdr1 As String = "Total Pressure Loss Calculations by Sections"

  Dim ColCrnt As Long
  Dim Section() As String
  Dim CriticalPath As String
  Dim InxSect As Long
  Dim Rng As Range
  Dim RowDestNext As Long
  Dim RowSrcLast As Long
  Dim RowTableHdr1 As Long
  Dim wshtDest As Worksheet
  Dim wshtSrc As Worksheet

  Set wshtSrc = Worksheets("Revit KBK Sonuç")
  Set wshtDest = Worksheets("Critical Path")

  With wshtDest
    .Cells.EntireRow.Delete
  End With

  ' I only work on the ActiveWorksheet if the user is to select the
  ' target worksheet in this way.  Code is easier to understand if
  ' With statements are used.
  With wshtSrc

    ' Copy column widths
    For ColCrnt = 1 To ColLast
      wshtDest.Columns(ColCrnt).ColumnWidth = .Columns(ColCrnt).ColumnWidth
    Next

    ' I avoid stringing commands together.  The resultant code may be
    ' marginally faster but it takes longer to write and much longer
    ' to decipher when you return to the macro in 12 months.

    ' Extract critial path string and convert to array of Section numbers
    RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
    CriticalPath = .Cells(RowSrcLast, "A").Value
    ' Extract text before trailing total pressure loss
    CriticalPath = Split(CriticalPath, ";")(0)
    ' Discard introductory text and trim spaces
    CriticalPath = Trim(Split(CriticalPath, ":")(1))
    Section = Split(CriticalPath, "-")

    Set Rng = .Cells.Find(What:=TableHdr1)

    If Rng Is Nothing Then
      Call MsgBox("I am unable to find the row containing """ & _
                                                       TableHdr1 & """", vbOKOnly)
      Exit Sub
    End If

    RowTableHdr1 = Rng.Row

    ' Copy header section of worksheet without buttons
    .Range(.Cells(1, 1), .Cells(RowTableHdr1 - 1, ColShtHdrLast)).Copy _
                                                Destination:=wshtDest.Cells(1, 1)
    ' Copy table header
    .Range(.Cells(RowTableHdr1, 1), .Cells(RowTableHdr1 + 1, ColLast)).Copy _
                                     Destination:=wshtDest.Cells(RowTableHdr1, 1)

    RowDestNext = RowTableHdr1 + 2

    ' Copy rows for each section in critical path to destination worksheet
    For InxSect = 0 To UBound(Section)

      Set Rng = .Columns("A:A").Find(What:=Section(InxSect), LookAt:=xlWhole)

      If Rng Is Nothing Then
        Call MsgBox("I am unable to find the row(s) for Section" & _
                                                   Section(InxSect), vbOKOnly)
      Else
        Set Rng = Rng.MergeArea       ' Expand to include all rows for section
        ' Copy all rows for section
        Rng.EntireRow.Copy Destination:=wshtDest.Cells(RowDestNext, 1)
        ' Step output row number
        RowDestNext = RowDestNext + Rng.Rows.Count
      End If

    Next

    ' Copy critical path row
    .Rows(RowSrcLast).EntireRow.Copy Destination:=wshtDest.Cells(RowDestNext, 1)
    RowDestNext = RowDestNext + 1

  End With

  ' Add border at bottom of output table
  With wshtDest
     With .Range(.Cells(RowDestNext, 1), _
                 .Cells(RowDestNext, ColLast)).Borders(xlEdgeTop)
       .LineStyle = xlContinuous
       .Weight = xlMedium
       .ColorIndex = 16
     End With
  End With

End Sub

响应请求的新版本宏

由于截面的行数不同，因此无法进行原位排序

版本1通过将所需行复制到不同的工作表来解决此问题。版本2通过将它们复制到原始表下但位于同一工作表内的工作区来解决此问题。也就是说，在旧桌子下面建了一张新桌子

新表完成后，将删除旧表以将新表移动到正确位置

Sub ertert()

  Const ColLast As Long = 10
  Const ColShtHdrLast As Long = 2
  Const TableHdr1 As String = "Total Pressure Loss Calculations by Sections"

  Dim ColCrnt As Long
  Dim Section() As String
  Dim CriticalPath As String
  Dim InxSect As Long
  Dim Rng As Range
  Dim RowDestNext As Long
  Dim RowDestStart As Long
  Dim RowSrcLast As Long
  Dim RowTableHdr1 As Long
  Dim wsht As Worksheet

  Set wsht = ActiveSheet

  With wsht

    ' Extract critial path string and convert to array of Section numbers
    RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
    CriticalPath = .Cells(RowSrcLast, "A").Value
    ' Extract text before trailing total pressure loss
    CriticalPath = Split(CriticalPath, ";")(0)
    ' Discard introductory text and trim spaces
    CriticalPath = Trim(Split(CriticalPath, ":")(1))
    Section = Split(CriticalPath, "-")

    Set Rng = .Cells.Find(What:=TableHdr1)

    If Rng Is Nothing Then
      Call MsgBox("I am unable to find the row containing """ & _
                                                       TableHdr1 & """", vbOKOnly)
      Exit Sub
    End If

    RowTableHdr1 = Rng.Row

    ' Because there is no fixed number of rows per section no in-situ sort is
    ' practical.  Instead copy required rows in required section to destination
    ' area below existing area.

    RowDestStart = RowSrcLast + 2
    RowDestNext = RowDestStart

    ' Copy rows for each section in critical path to destination area
    For InxSect = 0 To UBound(Section)

      Set Rng = .Columns("A:A").Find(What:=Section(InxSect), LookAt:=xlWhole)

      If Rng Is Nothing Then
        Call MsgBox("I am unable to find the row(s) for Section" & _
                                                   Section(InxSect), vbOKOnly)
      Else
        Set Rng = Rng.MergeArea       ' Expand to include all rows for section
        ' Copy all rows for section
        Rng.EntireRow.Copy Destination:=.Cells(RowDestNext, 1)
        ' Step output row number
        RowDestNext = RowDestNext + Rng.Rows.Count
      End If

    Next

    ' Copy critical path row
    .Rows(RowSrcLast).EntireRow.Copy Destination:=.Cells(RowDestNext, 1)
    RowDestNext = RowDestNext + 1


    ' Add border at bottom of output table
    With .Range(.Cells(RowDestNext, 1), _
                 .Cells(RowDestNext, ColLast)).Borders(xlEdgeTop)
      .LineStyle = xlContinuous
      .Weight = xlMedium
      .ColorIndex = 16
    End With

    ' Now have new table on rows RowDestStart to RowDestNext-1.
    ' Delete rows RowTableHdr1+2 to RowDestStart-1 (old table) to
    ' move new table into desired position.

    .Rows(RowTableHdr1 + 2 & ":" & RowDestStart - 1).EntireRow.Delete

  End With

End Sub

---

托尼：你太完美了：）太好了。但是如果我们只能做一张纸就更好了。我不需要关键路径，因为我会为每个报表关闭此excel文件。如果出了什么差错，我可以再复印一次报告。因为报告处于html模式。我复制它并粘贴到这里，然后单击Düzenle。你能把一张纸的代码发给我吗？@user3240191。我不知道如果答案更新，您是否会收到消息。此评论旨在确保您收到一条消息。顺便说一下，很高兴你喜欢我的第一个解决方案。我希望你更喜欢第二个版本。第二个版本非常好用。最后，我需要一些东西。有一个淡黄色按钮，用于清除纸张。当我点击它时，它会删除文本，但我不能取消所有单元格的合并并删除边框。下面是代码：Sub temizle（）将ws作为此工作簿中每个ws的工作表。工作表ws.UsedRange.ClearContents下一个ws End Sub

ws.Cells.ClearContents

删除大部分内容，但不是全部内容

ws.Cells.EntireRow.Delete

也会删除大部分内容，但不是全部。同时使用这两个选项，你应该删除所有内容。托尼，你节省了很多时间。非常感谢：）