Need Message Box For Sorting Code

[bamaisgreat]

Thanks as always for the Help.

I have been using the code below for several years and have run into a small problem. I have never had enough data in the sheet to go over the 250 columns until recently. I would like to have a message come up if I reach the 250th column telling me I have reached the end and give me the option to continue or start over.

Thanks again

Option Explicit
Sub test()Const myaddress = "D8:RO250"Const show_progress = False
Dim tolerance&, counter&, i&, j&, l&, lrow&, wrkrow&, summa&Dim mymax As Long, increasemoment As Long, myrange As Range, remembersel As Rangemymax = Range("H1").ValueSet remembersel = SelectionApplication.Calculation = xlCalculationManualApplication.ScreenUpdating = FalseColumns("A:A").Insert
Set myrange = Range(myaddress).Offset(0, 1)j = myrange.Column
'copy data in column A and add column B with RAND functionRange("A1:C1") = Split("Mk#,data,helper", ",")For i = j To Last(2, myrange) Step 2  Intersect(myrange, Cells(1, i).Resize(1, 2).EntireColumn).Copy  Cells(Last(1, Columns("A:A")), 1).Offset(1, 0).PasteSpecial xlValuesNext iRange("A2:B" & Last(1, Columns("A:A"))).Sort key1:=Range("B2"), Header:=xlNoCells(2, 3).Formula = "=RAND()"lrow = Last(1, Columns("A:A"))Cells(2, 3).AutoFill Destination:=Range("C2:C" & lrow)myrange.ClearContents'main loopincreasemoment = Range("H2").Offset(0, 1).Valuetolerance = Range("H3").Offset(0, 1).ValueDo    Application.Calculate    Range("A2:C" & lrow).Sort key1:=Range("C2"), Header:=xlNo    summa = Cells(lrow, 2)    wrkrow = lrow - 1    Do While summa + Val(Cells(wrkrow, 2)) <= mymax And wrkrow > 1      summa = summa + Cells(wrkrow, 2)      wrkrow = wrkrow - 1    Loop    counter = counter + 1    If show_progress Then Application.StatusBar = "Column " & j & " Tolerance " & tolerance & " Increase  " & increasemoment & " Counter " & counter    ' moving data to main table if found    If summa >= mymax - tolerance Or wrkrow = 1 Then      If (lrow - wrkrow) > myrange.Rows.Count Then MsgBox "Data extends below desired area", vbExclamation      Range(Cells(wrkrow + 1, 1), Cells(lrow, 2)).Copy      Cells(myrange.Row, j).PasteSpecial xlValues      Range(Cells(wrkrow + 1, 1), Cells(lrow, 3)).ClearContents      If show_progress Then        Application.ScreenUpdating = True        Application.ScreenUpdating = False      End If      lrow = wrkrow      j = j + 2      ' witn next subset start with the same as initial parameters      counter = 0      increasemoment = Range("H2").Offset(0, 1).Value      tolerance = Range("H3").Offset(0, 1).Value    ElseIf counter > increasemoment Then      ' easy boundary conditions if after several attempts not found good subset      tolerance = tolerance + 1      ' and also try to find subset in less iterations      increasemoment = CLng(WorksheetFunction.RoundUp(0.8 * increasemoment, 0))      counter = 0    End IfLoop Until wrkrow = 1
'cleaning upIf show_progress Then Application.StatusBar = ""Range("A1:A2:B1").ClearContentsColumns("C:C").Deleteremembersel.SelectApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticEnd Sub
Function Last(choice As Long, rng As Range)'Ron de Bruin, 5 May 2008' 1 = last row' 2 = last column' 3 = last cell    Dim lrw As Long    Dim lcol As Long
    Select Case choice
    Case 1:        On Error Resume Next        Last = rng.Find(What:="*", _                        After:=rng.Cells(1), _                        Lookat:=xlPart, _                        LookIn:=xlFormulas, _                        SearchOrder:=xlByRows, _                        SearchDirection:=xlPrevious, _                        MatchCase:=False).Row        On Error GoTo 0
    Case 2:        On Error Resume Next        Last = rng.Find(What:="*", _                        After:=rng.Cells(1), _                        Lookat:=xlPart, _                        LookIn:=xlFormulas, _                        SearchOrder:=xlByColumns, _                        SearchDirection:=xlPrevious, _                        MatchCase:=False).Column        On Error GoTo 0
    Case 3:        On Error Resume Next        lrw = rng.Find(What:="*", _                       After:=rng.Cells(1), _                       Lookat:=xlPart, _                       LookIn:=xlFormulas, _                       SearchOrder:=xlByRows, _                       SearchDirection:=xlPrevious, _                       MatchCase:=False).Row        On Error GoTo 0
        On Error Resume Next        lcol = rng.Find(What:="*", _                        After:=rng.Cells(1), _                        Lookat:=xlPart, _                        LookIn:=xlFormulas, _                        SearchOrder:=xlByColumns, _                        SearchDirection:=xlPrevious, _                        MatchCase:=False).Column        On Error GoTo 0
        On Error Resume Next        Last = rng.Parent.Cells(lrw, lcol).Address(False, False)        If Err.Number > 0 Then            Last = rng.Cells(1).Address(False, False)            Err.Clear        End If        On Error GoTo 0
    End SelectEnd Function

 

[mole999]

what version of excel are you using

256 was a limit in the past, now its over 16,000 cols

you might change
"D8:RO250" to "D8:RO500", haven't looked at the rest of the code

 

[bamaisgreat]

2016 Excel. I dont need to go over 250. I would like a message box saying I reached 250 in the code.
Thanks
Jamey