我使用宏来删除不包含我的报告数字的行。
此宏找到关键路径编号并将其拆分。在a1列中，它删除列表中不存在的数字。
这个宏工作正常。除此之外，我想按关键路径编号顺序对a1列进行排序。
In this link我添加了我想要的内容和我的报告文件。报告文件底部有一个关键路径文本。当我点击Düzenle宏删除行但不按关键路径编号顺序排序。
感谢您的帮助！
答案 0 :(得分：0)
我不喜欢同时执行复杂的更改和删除行。如果出现任何问题，您必须恢复工作表。我已经介绍了一个新的工作表“关键路径”，并已按照所需的顺序将工作表“RevitKBKSonuç”中所需的所有内容复制到其中。
我已经描述了我在做什么，为什么在宏中。我希望这一切都很清楚，但如果有必要的话就会问。
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