我在工作中为电子表格创建了这个程序。
我的代码几乎一直在运行，但有时它会毫无理由地决定是否出错。 （它没有显示任何错误消息，它只是不做它应该做的事情。它在排序时，有时它复制其他行的信息，但它应该全部为空白）
我的程序基本上是在同一张表中自动排序两个堆叠的表。
CODE：
Option Explicit
Sub Sorting()
' Keyboard Shortcut: Ctrl+m
'
'******************************* Define variables for the data that I want to store for later use
Dim MyDataFirstCell
Dim MyDataLastCell
Dim MySortCellStart
Dim MySortCellEnd
Dim MyDataFirstCell2
Dim MyDataLastCell2
Dim MySortCellStart2
Dim MySortCellEnd2
'************************** Establish the Data Area
ActiveSheet.Range("B1").Select
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select
DoEvents
MyDataFirstCell = ActiveCell.Address 'Get the first cell address of Data Area
Selection.End(xlDown).Select 'Get to Bottom Row of the data
Selection.End(xlToRight).Select 'Get to the last Column and data cell by heading to the righthand end
Selection.End(xlToRight).Select
ActiveCell.Offset(-1, 0).Select ' Select the correct last cell
MyDataLastCell = ActiveCell.Address 'Get the Cell address of the last cell of my data area
'************************** Establish the Sort column first and last data points.
ActiveSheet.Range("B1").Select
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select 'Get to first cell of data sort Column (Example Col 'R' Row 2 becuase Row 1 contains the header)
DoEvents
MySortCellStart = ActiveCell.Address 'Get the Cell address of the first cell of my data sort Column
Selection.End(xlDown).Select 'Get to the bottom Row of data
ActiveCell.Offset(-1, 0).Select
MySortCellEnd = ActiveCell.Address 'Get the Cell address of the last cell of my sort Column
'************************** Start the sort by specifying sort area and columns
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add _
Key:=Range(MySortCellStart & ":" & MySortCellEnd), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range(MyDataFirstCell & ":" & MyDataLastCell)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Second sorting
'************************** Establish the Data Area
ActiveSheet.Range("B1").Select
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
'Next Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
DoEvents
ActiveCell.Offset(1, 0).Select
MyDataFirstCell2 = ActiveCell.Address 'Get the first cell address of Data Area
Selection.End(xlDown).Select 'Get to Bottom Row of the data
Selection.End(xlToRight).Select 'Get to the last Column and data cell by heading to the righthand end
Selection.End(xlToRight).Select
ActiveCell.Offset(-1, 0).Select ' Select the correct last cell
MyDataLastCell2 = ActiveCell.Address 'Get the Cell address of the last cell of my data area
'************************** Establish the Sort column first and last data points.
ActiveSheet.Range("B1").Select
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
'Next Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select 'Get to first cell of data sort Column (Example Col 'R' Row 2 becuase Row 1 contains the header)
MySortCellStart2 = ActiveCell.Address 'Get the Cell address of the first cell of my data sort Column
Selection.End(xlDown).Select 'Get to the bottom Row of data
ActiveCell.Offset(-1, 0).Select
MySortCellEnd2 = ActiveCell.Address 'Get the Cell address of the last cell of my sort Column
'************************** Start the sort by specifying sort area and columns
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add _
Key:=Range(MySortCellStart2 & ":" & MySortCellEnd2), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range(MyDataFirstCell2 & ":" & MyDataLastCell2)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Select first element of first table
DoEvents
ActiveSheet.Range("F1").Select
Range(MyDataFirstCell).Select
End Sub
我是VBA编码的新手，我知道像C和LPC这样的语言，但我从来没有学过VBA。所以，任何有关如何解决问题或改进我的代码的帮助，我都是关于它的。
非常感谢您的耐心，关注和帮助。
答案 0 :(得分：0)
你的代码真的难以理解 - 很有可能在某些时候选择了错误的单元格，你随后尝试对单元格执行非法操作。
下面的代码将按第二列对工作簿中的所有区域进行排序（如果任何区域没有第二列，则可能会失败）。
重要的一点（除了我在代码中突出显示的重要位）是
Set rCurrentRegion = - 这需要参考您要排序的范围
它可以使用类似的方法手动设置
Set rCurrentRegion = ThisWorkbook.Worksheets("Sheet1").Range("A10:Z5000")。
在你的代码中它将是
Set rCurrentRegion = Range(MySortCellStart2 & ":" & MySortCellEnd2)（虽然您错过了工作表参考 - 否则它将作用于活动表格。）
Sub Test()
Dim Regions As Variant
Dim x As Long
Dim rCurrentRegion As Range
'Get a list of all the regions in your workbook as the range
'in your code doesn't appear to be in a static location.
'This will return an array of cell addresses.
'e.g. Regions(0) = "Sheet1!A4:P16"
' Regions(1) = "Sheet1!A21:L33"
Regions = FindRegionsInWorkbook(ThisWorkbook)
'Work through each element in the Regions array.
For x = LBound(Regions) To UBound(Regions)
'Turn the array element into a Range object.
Set rCurrentRegion = Range(Regions(x))
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'THIS IS THE IMPORTANT BIT '
'Sorting without selecting - the range that was '
'identified in the previous line of code is acted on. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The Parent of the range is the worksheet object.
With rCurrentRegion.Parent
.Sort.SortFields.Clear
'We're going to sort by the second column in the range.
.Sort.SortFields.Add _
Key:=rCurrentRegion.Columns(2), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
'Apply the sort.
With .Sort
.SetRange rCurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Next x
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This function returns all the separate regions in your workbook. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function FindRegionsInWorkbook(wrkBk As Workbook) As Variant
Dim ws As Worksheet, rRegion As Range, sRegion As String, sCheck As String
Dim sAddys As String, arrAddys() As String, aRegions() As Variant
Dim iCnt As Long, i As Long, j As Long
'//Cycle through each worksheet in workbook.
j = 0
For Each ws In wrkBk.Worksheets
sAddys = vbNullString
sRegion = vbNullString
On Error Resume Next
'//Find all ranges of constant & formula valies in worksheet.
sAddys = ws.Cells.SpecialCells(xlCellTypeConstants, 23).Address(0, 0) & ","
sAddys = sAddys & ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
If Right(sAddys, 1) = "," Then sAddys = Left(sAddys, Len(sAddys) - 1)
On Error GoTo 0
If sAddys = vbNullString Then GoTo SkipWs
'//Put each seperate range into an array.
If InStr(1, sAddys, ",") = 0 Then
ReDim arrAddys(0 To 0)
arrAddys(0) = "'" & ws.Name & "'!" & sAddys
Else
arrAddys = Split(sAddys, ",")
For i = LBound(arrAddys) To UBound(arrAddys)
arrAddys(i) = "'" & ws.Name & "'!" & arrAddys(i)
Next i
End If
'//Place region that range sits in into sRegion (if not already in there).
For i = LBound(arrAddys) To UBound(arrAddys)
If InStr(1, sRegion, ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0)) = 0 Then
sRegion = sRegion & ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0) & "," '*** no sheet
sCheck = Right(arrAddys(i), Len(arrAddys(i)) - InStr(1, arrAddys(i), "!"))
ReDim Preserve aRegions(0 To j)
aRegions(j) = Left(arrAddys(i), InStr(1, arrAddys(i), "!") - 1) & "!" & ws.Range(sCheck).CurrentRegion.Address(0, 0)
j = j + 1
End If
Next i
SkipWs:
Next ws
On Error GoTo ErrHandle
FindRegionsInWorkbook = aRegions
Exit Function
ErrHandle:
'things you might want done if no lists were found...
End Function