Repairs / Records Removed: Sorting

M

mharper90

Board Regular
Joined
May 28, 2013
Messages
117
Office Version
  1. 365
Platform
  1. MacOS
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!


Code: 
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
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Sort by date Sort by votes
try it like this:
Code: 
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:=ws2.Range("A3"), Order:=xlAscending
          .SortFields.Add Key:=ws2.Range("B3"), Order:=xlAscending
          .SetRange ws2.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], ordercustom:=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
 
Last edited:
Upvote 0
An aside ....

Code: 
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

could be replaced with
Code: 
     If LrA > 6 Then
        Set ws2 = ThisWorkbook.Sheets([COLOR=#ff0000]"P" & a & " Figure 2-2"[/COLOR])
        LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
     End If

within your code it will set the following sheets
P1 Figure 2-2
P2 Figure 2-2
P3 Figure 2-2
P4 Figure 2-2
P5 Figure 2-2
P6 Figure 2-2
P7 Figure 2-2
P8 Figure 2-2
 
Upvote 0
bobsan42 said:
try it like this:
Code: 
     With ws2.Sort
          .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
Click to expand...

I don't have internet on the LAN at work, so I'll have to manually make changes. This is the only section I noticed you revised, and just wanted to make sure?
 
Upvote 0
Yongle said:
An aside ....

Code: 
     If LrA > 6 Then
        Set ws2 = ThisWorkbook.Sheets([COLOR=#ff0000]"P" & a & " Figure 2-2"[/COLOR])
        LrB = ws2.Range("A" & Rows.Count).End(xlUp).Row
     End If

Thanks! I definitely appreciate the asides (kinda wish more people would throw them at me)! I'm very new to VBA, and just learning randomly off of the internet. I definitely take the long way in a lot of my code because I don't know the efficient ways yet. I'll be sure to implement this change and learn from it to save some time later.
Click to expand...
 
Upvote 0
Nope,
In this section I changed dots to commas.

in my second post i also changed a typo:
Code: 
ws2.Range("A7:Y" & LrC).Sort Key1:=[A7], [COLOR=#ff0000]ordercustom[/COLOR]:=Application.CustomListCount + 1
 
Upvote 0
Sorry for the late reply...it's been crazy busy at work. I made the changes and it still doesn't work. Anyone have any ideas?
 
Upvote 0
Another bump. This is killing my very elaborate document, and I just can't figure out why sorting is causing such a problem. Thanks!
 
Upvote 0
You should clear the existing sort fields before adding the new ones, or you'll be adding multiple sorts of the same field:

Rich (BB code): 
     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
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
VBA compare values on different sheets.
Replies
5
Views
148
rlv01
R
B
  • Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
303
B-radK
B
P
  • Question
Code used for comparison between 2 list.
Replies
3
Views
351
Tupe77
T
D
  • Question
Random selection modification not working
Replies
2
Views
187
Damian37
D
P
  • Question
Data not copying fully into ListBox2
Replies
0
Views
159
Patriot2879
P

Forum statistics

Threads
1,216,028
Messages
6,128,395
Members
449,446
Latest member
CodeCybear

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top