Sorting alphanumeric values

[Oxydo]

Hello everyone,

I have a file in which i need to sort a database extract based on an alphanummerical column. The column is set to text to ensure it doesnt sort numbers before text, which works well.

However, a problem arises when users 'neglect' to input 1A as 01A;
Excel sorts my file as follows: 10A, 10B, 11C, 19A, 1A, 20A, 2A, MM10, MM11, MM1
In stead of the desired: 1A, 2A, 10A, 10B, 11C, 19A, 20A, MM1, MM10, MM11.

If the user inputs 01A in stead of 1A it works fine, but sadly i dont have this control to enforce it in the system it's input into.

Does anyone know a solution to this problem?

Kind regards,

Oxydo

[Rabbit]

Prepend the 0 character to the ones that are missing it.

[Oxydo]

@Rabbit
Hi Rabbit,

I was thinking along the same lines. However, how do i put this in a formula? If i just add an 0 to everything it wont work, and the amount of possibilities (to search and replace or crosstab) is staggering (1A to 1ZZZ).

My other option would be to change the sortorder (is this possible) from 0123456789abcdef.. to abcdef0123456789.

Best regards,

Oxydo

[Rabbit]

You can't change the sort order like that. But you can grab the first two characters, check if it's numeric, if it's not, that means it's missing the 0 character, and then prepend it.

[ADezii]

Public Function fAnalyzeAlphaNumeric(strBaseString As String) As String
Select Case Val(Left$(strBaseString, 1))
  Case 1 To 9       'The 1st Character is a Number between 1 and 9
    'Is the 2nd Character an Alpha?
    If Asc(Mid$(UCase$(strBaseString), 2, 1)) >= 65 And _
       Asc(Mid$(UCase$(strBaseString), 2, 1)) <= 90 Then
      strBaseString = "0" & strBaseString
    Else    '1st Character 1 to 9, 2nd is Non-Alpha
      strBaseString = strBaseString
    End If
  Case Else    '1st Character not 1 to 9
    strBaseString = strBaseString
End Select
 
fAnalyzeAlphaNumeric = strBaseString
End Function

Debug.Print fAnalyzeAlphaNumeric("Hello World")
Returns: 'Hello World'

Debug.Print fAnalyzeAlphaNumeric("1A")
Returns: '01A'

Debug.Print fAnalyzeAlphaNumeric("55B")
Returns: '55B'

Debug.Print fAnalyzeAlphaNumeric("1ZZZZZZ")
Returns: '01ZZZZZZ'

[Oxydo]

Thanks for your reply ADezzi. I've tried to implement it into my code for extracting a DB to excel, then manipulating it. Sadly I'm now getting an invalid procedure error on the line;

    If Asc(Mid(UCase(strbasestring), 2, 1)) >= 65 And _
       Asc(Mid(UCase(strbasestring), 2, 1)) <= 90 Then
 

This is how i've added it to my code (the procedure is being called starting from line 116).

Option Explicit
 
Sub tellijstvest()
 
' ***
' *** Declareer de namen en typen van objecten en variabelen
' ***
 
Dim qdf As DAO.QueryDef
Dim dbs As DAO.Database
Dim rstTel As DAO.Recordset
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim blnheaderrow As Boolean, blnexcel As Boolean
Dim lngcolumn As Long, lastrow As Long
Dim strTemp As String, strx As String, strSQL As String, strTel As String, strBestandspad As String, strWorksheetnaam As String, strVestiging As String, strbasestring As String
' *** De tijdelijke query wordt zExporttellijst genoemd.
Const strTempQueryName As String = "zExportTellijst"
' *** Variabele dbs wordt gevuld met de gegevens van de huidige database
Set dbs = CurrentDb
' *** Gebruiker wordt gevraagd het vestigingsnummer op te geven
strVestiging = InputBox(Prompt:="Voor welke vestiging?", _
        Title:="Vestigingsnummer")
' *** Vervang de cursor door een zandloper
DoCmd.Hourglass True
' *** Het bestand wordt aangemaakt op de volgende locatie, met vestigingsnummer gevolgd door datum in de bestandsnaam.
strBestandspad = "C:\test\" & Format(Now(), "yyyy") & "\" & Format(Now(), "MMM") & "\" & strVestiging & " " & Format(Now(), "MMdd") & ".xls"
' *** onbekende code om de query te initialiseren
strTemp = dbs.TableDefs(0).Name
strSQL = "SELECT * FROM [" & strTemp & "] where 1=0;"
Set qdf = dbs.CreateQueryDef(strTempQueryName, strSQL)
qdf.Close
strTemp = strTempQueryName
 
' ***
' *** Gegevens ophalen
' ***
' *** alle regels en kolommen met het betreffende vestigingsnummer worden in een recordset opgeslagen
strSQL = "SELECT Kenteken, Naam, Artikel, Maat, Mk, Type, LV, RV, LA, RA, Locatie, Datum, Aantal from tbl_dbs_klantenbanden WHERE " & "Ves = " & strVestiging & ";"
Set rstTel = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)
' *** de eerste regel bevat kolomkoppen
blnheaderrow = True
' ***
' *** Excel bestand opstellen
' ***
'hier wordt een excel bestand gemaakt
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
    Set xlx = CreateObject("Excel.Application")
    blnexcel = True
End If
Err.Clear
On Error GoTo 0
xlx.Visible = False
' *** Nieuw werkboek wordt gemaakt, met het vestigingsnummer als naam.
Set xlw = xlx.workbooks.Add
Set xls = xlw.worksheets(1)
xls.Name = strVestiging
' *** Excel begint in veld A1
xls.Application.DisplayAlerts = False
Set xlc = xls.Range("A1")
' *** als er gegevens in de recordset staan worden deze naar excel geschreven
If rstTel.EOF = False And rstTel.BOF = False Then
' *** eerst de header
    For lngcolumn = 0 To rstTel.Fields.Count - 1
        xlc.offset(0, lngcolumn).Value = rstTel.Fields(lngcolumn).Name
' *** door naar de volgende
    Next lngcolumn
    Set xlc = xlc.offset(1, 0)
xlc.copyfromrecordset rstTel
End If
' ***
' *** Het excel bestand krijgt formatting
' ***
' *** Aantal rijen wordt opgeslagen in variabele lastrow
lastrow = xls.Range("B65535").End(xlUp).Row - 1
' *** Print op elke pagina de header
xls.PageSetup.PrintTitleRows = "$1:$1"
' *** Vervang de artikelcodes door Zomer / Winter
xls.Range("C:C").Replace What:="51500", Replacement:="WINTER", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
xls.Range("C:C").Replace What:="51502", Replacement:="WINTER", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
xls.Range("C:C").Replace What:="51503", Replacement:="ZOMER", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
xls.Range("C:C").Replace What:="51501", Replacement:="ZOMER", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
' *** verwijder bepaalde symbolen uit de locatie zodat de sortering beter verloopt
xls.Range("K:K").Replace What:=".", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
xls.Range("K:K").Replace What:=":", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
' *** Voeg een tijdelijke kolom toe met formule om kenteken en art.groep samen te voegen.
xls.Columns("A").Insert
xls.Range("A2").FormulaR1C1 = "=CONCATENATE(RC[1],RC[3])"
xls.Range("A2").Copy Destination:=xls.Range("A2").Resize(lastrow, 1)
' *** Zet de waarde ZW achter elke regel die zowel zomer als winterbanden heeft liggen in de vestiging
xls.Range("O1").Value = "ZW"
xls.Range("O2").FormulaR1C1 = "=IF(SUMIF(C[-13],RC[-13],C[-1])>SUMIF(C[-14],RC[-14],C[-1]),""ZW"","""")"
xls.Range("O2").Copy Destination:=xls.Range("O2").Resize(lastrow, 1)
' *** zet de waarde >4 achter elke regel die meer dan 4 banden heeft liggen in de vestiging
xls.Range("P1").Value = ">4"
xls.Range("P2").FormulaR1C1 = "=IF(SUMIF(C[-14],RC[-14],C[-2])>4,"">4"","""")"
xls.Range("P2").Copy Destination:=xls.Range("P2").Resize(lastrow, 1)
' *** vervang de formules door normale tekst
xls.Range("A:P") = xls.Range("A:P").Value
' *** verwijder de tijdelijke kolom
xls.Columns("A").Delete
xls.Columns("K").NumberFormat = "@"
Dim rngLocatie As Range
For Each xlc In xls.Range("K:K")
fAnalyzeAlphaNumeric (xlc.Value)
xlc.Value = strbasestring
Next
' *** Automatisch aanpassen van de kolombreedte
xls.Columns("A:S").EntireColumn.AutoFit
' ***
' *** De variabelen worden geleegd en bestanden gesloten
' ***
xls.Application.DisplayAlerts = False
rstTel.Close
Set rstTel = Nothing
Set xlc = Nothing
Set xls = Nothing
xlw.saveas strBestandspad
xlw.Close False
Set xlw = Nothing
If blnexcel = True Then xlx.Quit
Set xlx = Nothing
dbs.QueryDefs.Delete strTemp
dbs.Close
Set dbs = Nothing
DoCmd.Hourglass False
End Sub
 
Public Function fAnalyzeAlphaNumeric(strbasestring As String) As String
Select Case Val(Left$(strbasestring, 1))
  Case 1 To 9       'The 1st Character is a Number between 1 and 9
    'Is the 2nd Character an Alpha?
    If Asc(Mid(UCase(strbasestring), 2, 1)) >= 65 And _
       Asc(Mid(UCase(strbasestring), 2, 1)) <= 90 Then
      strbasestring = "0" & strbasestring
    Else    '1st Character 1 to 9, 2nd is Non-Alpha
      strbasestring = strbasestring
    End If
  Case Else    '1st Character not 1 to 9
    strbasestring = strbasestring
End Select
 
fAnalyzeAlphaNumeric = strbasestring
End Function
 

Any further pointers would be appreciated.

Regards,

Oxydo

[ADezii]

It appears as though you are using Automation Code to Open an Instances of Excel, populate a Worksheet with Data, than pass all Values within a specific Range to an Access Function for evaluation and return.

Run an Update Query in Access to provide the desired Values, then base the rstTel Recordset on the Fields with these Updated Values.

P.S. - It is also possible that the Function is receiving Zero Length Strings, Strings of Length < 2, or NULL Values. In either one of these cases, the Logic will fail. I modified the Code and added a Band Aid to see if will possibly work with these adjustments.

Public Function fAnalyzeAlphaNumeric(varBaseString As Variant) As Variant
If IsNull(varBaseString) Then
  fAnalyzeAlphaNumeric = Null
    Exit Function
ElseIf Len(varBaseString) < 2 Then
  fAnalyzeAlphaNumeric = varBaseString
    Exit Function
End If
 
Select Case Val(Left$(varBaseString, 1))
  Case 1 To 9       'The 1st Character is a Number between 1 and 9
    If Asc(Mid$(UCase$(varBaseString), 2, 1)) >= 65 And _
       Asc(Mid$(UCase$(varBaseString), 2, 1)) <= 90 Then
      varBaseString = "0" & varBaseString
    Else
      varBaseString = varBaseString
    End If
  Case Else
    varBaseString = varBaseString
End Select
 
fAnalyzeAlphaNumeric = varBaseString
End Function

[Oxydo]

Hi Adezzi,

Since receiving your reply i've changed my code around somewhat to do most of the work in access itself, to be able to use your function. I'm now at the point where the data is put through a make table query, and stored in a temporary db.

At this point in the code i would like to call your function, but im not sure how.

Sub tellijstvest()
 
' ***
' *** Declareer de namen en typen van objecten en variabelen
' ***
 
Dim qdf As DAO.QueryDef
Dim dbs As DAO.Database
Dim rstTel As DAO.Recordset
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim blnheaderrow As Boolean, blnexcel As Boolean
Dim lngcolumn As Long, lastrow As Long
Dim strTemp As String, strx As String, strSQL As String, strTel As String, strBestandspad As String, strWorksheetnaam As String, strVestiging As String, strbasestring As String
' *** De tijdelijke query wordt zExporttellijst genoemd.
Const strTempDBSName As String = "zExportTellijst"
' *** Variabele dbs wordt gevuld met de gegevens van de huidige database
Set dbs = CurrentDb
' *** Gebruiker wordt gevraagd het vestigingsnummer op te geven
strVestiging = InputBox(Prompt:="Voor welke vestiging?", _
        Title:="Vestigingsnummer")
' *** Vervang de cursor door een zandloper
'DoCmd.Hourglass True
' *** Het bestand wordt aangemaakt op de volgende locatie, met vestigingsnummer gevolgd door datum in de bestandsnaam.
strBestandspad = "C:\test\" & Format(Now(), "yyyy") & "\" & Format(Now(), "MMM") & "\" & strVestiging & " " & Format(Now(), "MMdd") & ".xls"
' *** onbekende code om de query te initialiseren
strTemp = dbs.TableDefs(0).Name
strSQL = "Select Kenteken, Naam, Artikel, Maat, Mk, Type, LV, RV, LA, RA, Locatie, Datum, Aantal into ztbl_tellijst From tbl_dbs_klantenbanden where " & " Ves = " & strVestiging & ";"
Set qdf = dbs.CreateQueryDef(strTempDBSName, strSQL)
qdf.Execute
 
.....
 

COuld you provide me with yet another great help?

Kind regards,

Oxydo

[ADezii]

If I understand you correctly, your non-formatted Data now resides in a Temporary Table. Let's assume that this Table Name is tblTEMP, and that the Field that needs to run through the Function to be properly Formatted is [Field1]. A simple Update Query will subsequently leave [Field1] in tblTEMP in the proper State. The SQL would be:

UPDATE tblTEMP SET tblTEMP.Field1 = fAnalyzeAlphaNumeric([Field1])

[Oxydo]

Works great, thanks a lot!

Regards,

Oxydo

[ADezii]

You are quite welcome, Oxydo.