私のコードはほとんどの時間で動作しますが、

Question

私は自分の仕事でスプレッドシート用にこのプログラムを作成しました。

私のコードはほとんど常に動作しますが、何らかの理由でバグを起こすことがあります。 （エラーメッセージは表示されません。ソート時には他の行の情報がコピーされることがありますが、すべて空白にしてください）

私のプログラムは基本的に同じシート内の2つの積み重ねられたテーブルを自動的にソートする。

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を学んだことがありません。だから、問題を解決する方法やコードを改善する方法の助けを借りて、私はそれについてすべてです。

ご理解とご協力をいただき、ありがとうございます。

Answer 1

あなたはコードを実行するのが本当に難しいです。間違ったセルがある時点で選択され、その後、セルに対して不正な操作を実行しようとしている可能性があります。

次のコードは、ブック内のすべての領域を2番目の列で並べ替えます（2番目の列がない領域があれば失敗する可能性があります）。 （私はコードで強調表示しました重要なビット以外の）

重要なビットは
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