Sorting

**pleasehelp2008** · 02-18-2010, 05:38 PM

I need to be able to alphabetize this list and later remove businesses based upon the expiration date. However due to the way the address (some over 2 cells, some over 3 cells) and business names are split into separate cells, I cannot figure out how to sort?

Attached is a sample of the file.

Any help would really be appreciated!

Thanks!

**mdbct** · 02-19-2010, 12:32 AM

The following will:
Sort based on the name in each box in column 1
Delete any companies with an expiration date before Nov 1, 2009
Re-draw the borders

comment out the lines it 'x-x-x-x at the ends if you do not want to delet based on a date

Code:

Option Explicit

Sub specSort()
Dim lRow As Long, i As Long, iB As Integer, iCombo As Integer
Dim strName As String, strDel As String, rBord As Range
'determine last row
Application.ScreenUpdating = False

lRow = Cells.Find(what:="*", searchdirection:=xlPrevious).Row

'numbers groups determined by top border
For i = 2 To lRow
    If Cells(i, 1).Borders(xlEdgeTop).LineStyle = 1 Then
        iB = 1
        Cells(i, 9) = iB
        If Cells(i, 3) < DateSerial(2009, 11, 1) Then   'x-x-x-x
            strDel = "X"                                'x-x-x-x
        Else                                            'x-x-x-x
            strDel = ""                                 'x-x-x-x
        End If                                          'x-x-x-x
            Cells(i, 7) = strDel                        'x-x-x-x
    Else
        iB = iB + 1
        Cells(i, 9) = iB
        Cells(i, 7) = strDel                            'x-x-x-x
        
    End If
Next

For i = 3 To lRow + 1
    If Cells(i, 9) = 1 Or Cells(i, 9) = "" Then
        strName = ""
        For iCombo = i - Cells(i - 1, 9) To i - 1
            strName = strName & Cells(iCombo, 1)
        Next
            Range(Cells(i - Cells(i - 1, 9), 8), Cells(i - 1, 8)) = strName
    End If
Next

Range(Cells(2, 1), Cells(lRow, 9)).Sort key1:=Cells(2, 8), order1:=xlAscending, header:=xlNo

Cells(1, 7) = "Del"                                                                     'x-x-x-x
Range(Cells(1, 1), Cells(lRow, 9)).AutoFilter field:=7, Criteria1:="X"                  'x-x-x-x
Range(Cells(2, 1), Cells(lRow, 9)).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp   'x-x-x-x
Cells.AutoFilter                                                                        'x-x-x-x

lRow = Cells.Find(what:="*", searchdirection:=xlPrevious).Row
Set rBord = Range(Cells(2, 1), Cells(lRow, 9))
rBord.Borders.LineStyle = xlNone
For i = 3 To lRow + 1
    If Cells(i, 9) = 1 Or Cells(i, 9) = "" Then
        Set rBord = Range(Cells(i - Cells(i - 1, 9), 1), Cells(i - 1, 5))
        rBord.Select
    With rBord.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rBord.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rBord.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rBord.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rBord.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

End If
Next
Range("G:I").EntireColumn.Delete
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub

**protonLeah** · 02-19-2010, 03:58 AM

The below macro will reformat and sort your data on sheet2

Code:

Option Explicit
Option Base 1
Sub OneRecordPerRow()
    Dim AddrColumn          As Range, _
        TestAddress         As Range, _
        ExpiryRows()        As Long, _
        ZipRows()           As Long, _
        RecordSpan()        As Long, _
        LastAddress         As Long, _
        ZipIndex            As Long, _
        ExpiryIndex         As Long, _
        IndexCtrl           As Long, _
        NewRecordRow        As Long, _
        NameRowNum          As Long, _
        NewHeaders
        
    NewHeaders = Array("Firm", "Alias/Owner", "License Class", "Expiration Date", "Address", "City", "State", "Zip", "Site")
    Sheets("sheet1").Select

    LastAddress = Cells(Rows.Count, "D").End(xlUp).Row
    Set AddrColumn = Range("D2:D" & LastAddress)
    
    For Each TestAddress In AddrColumn
    
        'Get the row number of the Expiration Date.
        'This is assumed to be the first row of each record.
        
        If IsDate(TestAddress.Offset(0, -1).Value) Then
            ExpiryIndex = ExpiryIndex + 1
            ReDim Preserve ExpiryRows(ExpiryIndex)
            ExpiryRows(ExpiryIndex) = TestAddress.Row
        End If
        
        'Get the row number of the Zip Code for each firm
        'This is assumed to be the last row used for the record.
        
        If IsNumeric(Trim(Right(TestAddress.Value, 5))) Then
            ZipIndex = ZipIndex + 1
            ReDim Preserve ZipRows(ZipIndex)
            ZipRows(ZipIndex) = TestAddress.Row
        End If
    Next TestAddress
    
    'Assuming that ZipIndex and ExpiryIndex will always be equal,
    'Calculate number of rows used for each record
    
    ReDim RecordSpan(ZipIndex)
    For IndexCtrl = 1 To ZipIndex
        RecordSpan(IndexCtrl) = ZipRows(IndexCtrl) - ExpiryRows(IndexCtrl) + 1
    Next IndexCtrl
    
'  *****    Conflate multiple row records to a single row on sheet 2   *****

    For IndexCtrl = 1 To UBound(NewHeaders)
        Sheets("Sheet2").Cells(1, IndexCtrl).Value = NewHeaders(IndexCtrl)
    Next IndexCtrl
    
    For IndexCtrl = 1 To ExpiryIndex
        NewRecordRow = IndexCtrl + 1
        
        'firm name
        Sheets("Sheet2").Cells(NewRecordRow, "A").Value = Sheets("Sheet1").Cells(ExpiryRows(IndexCtrl), "A").Value
        
        'firm owner/alias from second row in the block
        Sheets("sheet2").Cells(NewRecordRow, "B").Value = Sheets("sheet1").Cells(ExpiryRows(IndexCtrl) + 1, "A").Value
        
        'license class
        Sheets("sheet2").Cells(NewRecordRow, "C").Value = Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "B").Value
        
        'Expiry Date
        Sheets("Sheet2").Cells(NewRecordRow, "D").Value = Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "C").Value
        
        'Street address
        'expiry date is always in the first row of the record block and zip code row is the last row of the block, ergo
        'zip row - expiry row +1 is the number of rows in address
        'if the total is 3 then concatenate the first two rows
        Sheets("sheet2").Cells(NewRecordRow, "E").Value = _
           IIf(ZipRows(IndexCtrl) - ExpiryRows(IndexCtrl) + 1 = 3, _
           Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "D").Value & " " & Sheets("sheet1").Cells(ExpiryRows(IndexCtrl) + 1, "D").Value, _
           Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "D").Value)
        'city
         Sheets("sheet2").Cells(NewRecordRow, "F").Value = _
         Left(Sheets("sheet1").Cells(ZipRows(IndexCtrl), "D").Value, Len(Sheets("sheet1").Cells(ZipRows(IndexCtrl), "D").Value) - 11)
            
        'state
         Sheets("sheet2").Cells(NewRecordRow, "G").Value = _
         Mid(Sheets("sheet1").Cells(ZipRows(IndexCtrl), "D").Value, WorksheetFunction.Find(",", Sheets("sheet1").Cells(ZipRows(IndexCtrl), "D").Value) + 2, 2)
        
        'zip
        Sheets("sheet2").Cells(NewRecordRow, "H").Value = _
         Right(Trim(Sheets("sheet1").Cells(ZipRows(IndexCtrl), "D").Value), 5)
        
        'site
        Sheets("sheet2").Cells(NewRecordRow, "I").Value = Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "E").Value
    Next IndexCtrl
    
    Sheets("sheet2").Select
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A1:I" & ZipIndex)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

**pleasehelp2008** · 02-22-2010, 03:51 AM

THANK YOU! THIS CODE WORKS CORRECTLY, HOWEVER I NEED TO RUN THIS ON 16,000 RECORDS AND IT GIVES THIS ERROR WHEN RUN ON THE WHOLE EXCEL FILE:
Run time error '9'

Subscript out of range

and when I try to see THE ERROR it highlights this line of code:

RecordSpan(IndexCtrl) = ZipRows(IndexCtrl) - ExpiryRows(IndexCtrl) + 1

Originally Posted by mdbct

The following will:
Sort based on the name in each box in column 1
Delete any companies with an expiration date before Nov 1, 2009
Re-draw the borders

comment out the lines it 'x-x-x-x at the ends if you do not want to delet based on a date

Code:

Option Explicit

Sub specSort()
Dim lRow As Long, i As Long, iB As Integer, iCombo As Integer
Dim strName As String, strDel As String, rBord As Range
'determine last row
Application.ScreenUpdating = False

lRow = Cells.Find(what:="*", searchdirection:=xlPrevious).Row

'numbers groups determined by top border
For i = 2 To lRow
    If Cells(i, 1).Borders(xlEdgeTop).LineStyle = 1 Then
        iB = 1
        Cells(i, 9) = iB
        If Cells(i, 3) < DateSerial(2009, 11, 1) Then   'x-x-x-x
            strDel = "X"                                'x-x-x-x
        Else                                            'x-x-x-x
            strDel = ""                                 'x-x-x-x
        End If                                          'x-x-x-x
            Cells(i, 7) = strDel                        'x-x-x-x
    Else
        iB = iB + 1
        Cells(i, 9) = iB
        Cells(i, 7) = strDel                            'x-x-x-x
        
    End If
Next

For i = 3 To lRow + 1
    If Cells(i, 9) = 1 Or Cells(i, 9) = "" Then
        strName = ""
        For iCombo = i - Cells(i - 1, 9) To i - 1
            strName = strName & Cells(iCombo, 1)
        Next
            Range(Cells(i - Cells(i - 1, 9), 8), Cells(i - 1, 8)) = strName
    End If
Next

Range(Cells(2, 1), Cells(lRow, 9)).Sort key1:=Cells(2, 8), order1:=xlAscending, header:=xlNo

Cells(1, 7) = "Del"                                                                     'x-x-x-x
Range(Cells(1, 1), Cells(lRow, 9)).AutoFilter field:=7, Criteria1:="X"                  'x-x-x-x
Range(Cells(2, 1), Cells(lRow, 9)).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp   'x-x-x-x
Cells.AutoFilter                                                                        'x-x-x-x

lRow = Cells.Find(what:="*", searchdirection:=xlPrevious).Row
Set rBord = Range(Cells(2, 1), Cells(lRow, 9))
rBord.Borders.LineStyle = xlNone
For i = 3 To lRow + 1
    If Cells(i, 9) = 1 Or Cells(i, 9) = "" Then
        Set rBord = Range(Cells(i - Cells(i - 1, 9), 1), Cells(i - 1, 5))
        rBord.Select
    With rBord.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rBord.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rBord.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rBord.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rBord.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

End If
Next
Range("G:I").EntireColumn.Delete
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub

**pleasehelp2008** · 02-22-2010, 03:52 AM

THANK YOU! THIS CODE WORKS CORRECTLY, HOWEVER I NEED TO RUN THIS ON 16,000 RECORDS AND IT GIVES THIS ERROR WHEN RUN ON THE WHOLE EXCEL FILE:
Run time error '9'

Subscript out of range

and when I try to see THE ERROR it highlights this line of code:

RecordSpan(IndexCtrl) = ZipRows(IndexCtrl) - ExpiryRows(IndexCtrl) + 1

**protonLeah** · 02-22-2010, 11:20 PM

No sure what you did. The error line you posted is from my procedure. But, the procedure you posted is from mdbct. I copied your sample data to get 16800 rows and the procedure ran without error??

**djshiggles** · 02-25-2010, 04:48 AM

Originally Posted by protonLeah

No sure what you did. The error line you posted is from my procedure. But, the procedure you posted is from mdbct. I copied your sample data to get 16800 rows and the procedure ran without error??

Hello, I am the one looking for help with this issue, my buddy was on here posting for me..

Im not sure whats going on. Perhaps I am running the code wrong?

I have a sheet with 13250 rows. With that sheet open, Im clicking VIEW CODE in the developer tab which opens a visual basic window. I copy your code in there... and click run.

I keep getting RUNTIME ERROR '9" Subscript out of range...

The other night I got it to work on small samples, but now even thats not working...

I've attached the full file, if that helps...

Please let me know what I am doing wrong???

Thanks!!

**mdbct** · 02-25-2010, 09:59 AM

I've attached your file after running the macro I had supplied. Sheet1 shows the sorted data with all dates included. Sheet2 shows sorted data with expiration dates before Nov 1, 2009 removed.

x-x-x-x Edit x-x-x-x
The file, with both sheets, exceeds the allowable size for attachments.

I've removed Sheet1.

x-x-x-x-Edit x-x-x-x

**djshiggles** · 02-26-2010, 04:20 PM

Originally Posted by mdbct

I've attached your file after running the macro I had supplied. Sheet1 shows the sorted data with all dates included. Sheet2 shows sorted data with expiration dates before Nov 1, 2009 removed.

x-x-x-x Edit x-x-x-x
The file, with both sheets, exceeds the allowable size for attachments.

I've removed Sheet1.

x-x-x-x-Edit x-x-x-x

Thanks very much, but this is not what I was originally trying to do... I need all of the information for each entry to be on one row (i.e. some of the addresses take up 3 rows) so that I can sort by any of the column headings.

Like i said in my last post, that other code was working for me on small samples but not on the whole sheet...

*EDIT*

So in the one you sent me back, if you try to sort by any of the headings, you end up with all of the addresses split up because of the alphabetizing...

The code that proton Leah gave seemed to work at first on a small smaple, but now i keep getting error messages...

Thanks again.

**mdbct** · 02-26-2010, 05:09 PM

It is erroring out at that line because there are 5434 records in the Recordspan and ZipRows arrays and only 5372 records in the ExpriryRows data. The loop is set to loop through 5434 records based on the ZipIndex variable which is 5435.

I limited the loop to the number of number of records in ExpriryRows and the macro ran into problems with rows on the spreadsheet where there were numbers in the right most position that weren't Zip codes. Two stumbling blocks were rows with PO boxes numbers and about 45 rows that had the numbers 1 or 2 entered into a cell.

**protonLeah** · 02-28-2010, 02:42 AM

This is the modified code:

Code:

Option Explicit
Option Base 1
 Sub OneRecordPerRow()       'MOD'D 02/27/2010
    Application.ScreenUpdating = False
    Dim AddrColumn          As Range, _
        TestAddress         As Range, _
        ExpiryRows()        As Long, _
        ExpiryIndex         As Long, _
        RecordSpan()        As Long, _
        LastAddress         As Long, _
        IndexCtrl           As Long, _
        NewRecordRow        As Long, _
        AddrBuilder         As String, _
        NewHeaders, _
        temparray
    
    NewHeaders = Array("Firm", "Alias/Owner", "License Class", "Expiration Date", "Address", "City", "State", "Zip", "Site")
    Sheets("sheet1").Select

    LastAddress = Cells(Rows.Count, "D").End(xlUp).Row
    Set AddrColumn = Range("C2:C" & LastAddress)
    
    For Each TestAddress In AddrColumn
    
        'Get the row number of the Expiration Date.
        'This is assumed to be the first row of each record.
        
        If IsDate(TestAddress.Value) Then
            ExpiryIndex = ExpiryIndex + 1
            ReDim Preserve ExpiryRows(ExpiryIndex)
            ExpiryRows(ExpiryIndex) = TestAddress.Row
        End If
     Next TestAddress
     
     ReDim RecordSpan(1 To UBound(ExpiryRows))
     For IndexCtrl = 1 To UBound(ExpiryRows) - 1
        RecordSpan(IndexCtrl) = ExpiryRows(IndexCtrl + 1) - ExpiryRows(IndexCtrl)
     Next IndexCtrl
     RecordSpan(UBound(RecordSpan)) = LastAddress - ExpiryRows(ExpiryIndex) + 1
     
    
'  *****    Conflate multiple row records to a single row on sheet 2   *****

    'build the header/title row
    For IndexCtrl = 1 To UBound(NewHeaders)
        Sheets("Sheet2").Cells(1, IndexCtrl).Value = NewHeaders(IndexCtrl)
    Next IndexCtrl

    For IndexCtrl = 1 To UBound(ExpiryRows)
        NewRecordRow = IndexCtrl + 1
        
        'firm name
        Sheets("Sheet2").Cells(NewRecordRow, "A").Value _
        = Sheets("Sheet1").Cells(ExpiryRows(IndexCtrl), "A").Value
        
        'firm owner/alias from second row in the block
        Sheets("sheet2").Cells(NewRecordRow, "B").Value = Sheets("sheet1").Cells(ExpiryRows(IndexCtrl) + 1, "A").Value
        
        'license class
        Sheets("sheet2").Cells(NewRecordRow, "C").Value = _
            Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "B").Value
        
        'Expiry Date
        Sheets("Sheet2").Cells(NewRecordRow, "D").Value = _
            Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "C").Value
        
        'Street address
        AddrBuilder = Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "D").Value
        If RecordSpan(IndexCtrl) = 3 Then
            AddrBuilder = AddrBuilder & " " & Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "D").Offset(1, 0).Value
        End If
        Sheets("sheet2").Cells(NewRecordRow, "E").Value = AddrBuilder
            
        'city
        Dim x As Long
        AddrBuilder = Trim(Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "D").Offset(RecordSpan(IndexCtrl) - 1, 0).Value)
        temparray = Split(AddrBuilder, ",")
        
        Sheets("sheet2").Cells(NewRecordRow, "F").Value = Trim(temparray(0))
            
        'state
        AddrBuilder = Trim(temparray(1))
        temparray = Split(AddrBuilder)
         Sheets("sheet2").Cells(NewRecordRow, "G").Value = temparray(0)
        
        'zip
        'remove dangling '-'
        If Len(temparray(1)) > 5 And Len(temparray(1)) < 10 Then
            temparray(1) = Left(temparray(1), 5)
        End If
        Sheets("sheet2").Cells(NewRecordRow, "H").Value = temparray(1)
        
        'site
        Sheets("sheet2").Cells(NewRecordRow, "I").Value = Sheets("sheet1").Cells(ExpiryRows(IndexCtrl), "E").Value

    Next IndexCtrl
    
    Sheets("sheet2").Columns("H:H").NumberFormat = "@"
    Sheets("sheet2").Select

    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A1:I" & ExpiryIndex)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Sheets("sheet2").Rows("1:1").Select
    With Selection
        .Font.Name = "Tahoma"
        .Font.Size = 12
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Application.ScreenUpdating = True
End Sub

It seems to account for the extraneous dashes and spaces, etc in your records.

**djshiggles** · 03-08-2010, 10:44 PM

Thank you!!! You are my hero!!!!

Thread: Sorting

Thread Tools

Display

Sorting

Re: Help with sorting

Re: Sorting

Re: Help with sorting

Re: Help with sorting

Re: Sorting

Re: Sorting

Re: Sorting

Re: Sorting

Re: Sorting

Re: Sorting

Re: Sorting

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions