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

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
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

Logit
  • Question Question
Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process
Replies
7
Views
357
Logit
Logit
T
  • Question Question
VBA compare values on different sheets.
Replies
5
Views
696
rlv01
R
N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
667
myall_blues
myall_blues
K
  • Solved
Code to search job id from multiple sources and update main spreadsheet.
2
Replies
10
Views
681
mumps
mumps
B
  • Question Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
572
B-radK
B

Forum statistics

Threads
1,224,823
Messages
6,181,177
Members
453,021
Latest member
Justyna P

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