Repairs / Records Removed: Sorting

[mharper90]

I have a file that consistently reports "Excel was able to open the file by repairing or removing the unreadable content". I have narrowed it down to a single macro which runs, and it seems to only cause "damage" when the file is opened on a different computer (on the same LAN) from which the macro was last run on. The repair log states that it removed "Sorting" from sheets 2, 3, 4, 5, 6, 7, 8, 9. These are the 8 sheets affected by the macro I believe to be the culprit.

Below is a copy of my macro. Really hoping someone knows how to fix this, since this gigantic Excel program is basically garbage if it can't open properly...lol. Thanks!

Sub cleanallF22()

Dim x     As String
Dim a     As Long
Dim ws1     As Worksheet: Set ws1 = ThisWorkbook.Sheets("Main Data")
Dim ws2     As Worksheet
Dim LrA     As Long
Dim LrB2     As Long
Dim LrC     As Long
Dim vSortList     As Variant

LrA = ws1.Range("A" & Rows.Count).End(xlUp).Row

For a = 1 to 8

     If LrA > 6 Then
          If a = "1" Then
               Set ws2 = ThisWorkbook.Sheets("P1 Figure 2-2")
               LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
          ElseIf a = "2" Then
               Set ws2 = ThisWorkbook.Sheets("P2 Figure 2-2")
               LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
          ElseIf a = "3" Then
               Set ws2 = ThisWorkbook.Sheets("P3 Figure 2-2")
               LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
          ElseIf a = "4" Then
               Set ws2 = ThisWorkbook.Sheets("P4 Figure 2-2")
               LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
          ElseIf a = "5" Then
               Set ws2 = ThisWorkbook.Sheets("P5 Figure 2-2")
               LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
          ElseIf a = "6" Then
               Set ws2 = ThisWorkbook.Sheets("P6 Figure 2-2")
               LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
          ElseIf a = "7" Then
               Set ws2 = ThisWorkbook.Sheets("P7 Figure 2-2")
               LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
          ElseIf a = "8" Then
               Set ws2 = ThisWorkbook.Sheets("P8 Figure 2-2")
               LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
          End If
     End If

     Application.ScreenUpdating = False

     LrB2 = ws2.Range("A" & Rows.Count).End(xlUp).Row

     On Error Resume Next

     With ws2.Sort
          .SortFields.Add Key:=Range("A3"). Order:=xlAscending
          .SortFields.Add Key:=Range("B3"). Order:=xlAscending
          .SetRange Range("A3:Y" & LrB2)
          .Apply
     End With

     On Error GoTo 0

     LrC = ws2.Range("A" & Rows.Count).End(xlUp).Row
     vSortList = Array("YES", "NO", "MDR", "DPL")

     Application.AddCustomList ListArray:=vSortList
     ws2.Range("A7:Y" & LrC).Sort Key1:=[D7], Order1:=xlAscending
     ws2.Range("A7:Y" & LrC).Sort Key1:=[A7], ordercustos:=Application.CustomListCount + 1
     ws2.Range("A7:Y" & LrC).Sort Key1:=[B7], Order1:=xlAscending

     x = Application.GetCustomListNum(ListArray:=vSortList)
     Application.DeleteCustomList x

     ws2.Range("B1").Select

Next a

ActiveWorkbook.SortFields.Clear

Application.ScreenUpdating = True

End Sub

 

[bobsan42]

What RoryA suggests makes a lot of sense.
However - if this fails to help maybe you'll have to share your file for inspecting the code, the changes and the errors.

 

[mharper90]

You should clear the existing sort fields before adding the new ones, or you'll be adding multiple sorts of the same field:

     With ws2.Sort
          .Sortfields.Clear
          .SortFields.Add Key:=ws2.Range("A3"), Order:=xlAscending
          .SortFields.Add Key:=ws2.Range("B3"), Order:=xlAscending
          .SetRange ws2.Range("A3:Y" & LrB2)
          .Apply
     End With

Thanks! I implemented this and it works perfectly now! Thank you so much!