1
\$\begingroup\$

The following code clears 11 columns that contain lists that are used for data validation on another worksheet. This list is constantly changing due to records being added/removed from the source data. Basically I'm checking every value in a column, and if it meets all of my criteria I'm adding it to my data validation column (after making sure it doesn't already exist there).

Once I've populated my 11 columns, I sort each one alphabetically. This is the portion of my code that I don't like. While it doesn't explicitly select anything, I can see on my worksheet the last column that was sorted because it is selected.

What I'm wondering is if there's a better way to dynamically generate this list alphabetically without having to use .Sort - possibly populating an array and then sorting it alphabetically? I've never sorted an array in VBA, so I'm not sure 1. If it's even more efficient and 2. What is the best method to sort an array, if that's the approach I should take here?

Code:

Option Explicit
Sub PopulateAllDataValidationLists()

    Dim sht As Worksheet, sht2 As Worksheet
    Dim i As Long, listcol As Long

    Set sht = Worksheets("Sheet 1")
    Set sht2 = Worksheets("Data Validation")

        Application.ScreenUpdating = False

        sht2.Range("A2:K500").ClearContents

        For i = 1 To 11
            listcol = sht.Rows("1:1").Find(What:=sht2.Cells(1, i).Value, LookAt:=xlWhole).Column

            For j = 2 To sht.Cells(sht.Rows.Count, listcol).End(xlUp).Row
                If IsError(Application.Match(sht.Cells(j, listcol).Value, sht2.Range(ColumnLetter(i) & ":" & ColumnLetter(i)), 0)) And _
                sht.Cells(j, listcol).Value <> "" And _
                sht.Cells(j, listcol).Value <> "UNK" And _
                sht.Cells(j, listcol).Value <> "xxx" And _
                sht.Cells(j, listcol).Value <> "yyy" And _
                sht.Cells(j, listcol).Value <> "zzz" And _
                sht.Cells(j, listcol).Value <> "yxz" And _
                sht.Cells(j, listcol).Value <> "zyx" And _
                Len(sht.Cells(j, listcol).Value) <= 3 Then
                    sht2.Cells(sht2.Cells(sht2.Rows.Count, i).End(xlUp).Row + 1, i).Value = sht.Cells(j, listcol).Value
                End If
            Next j

        Next i

        'Sort all alphabetically
        For i = 1 To 11
            Worksheets("Data Validation").Sort.SortFields.Clear
            Worksheets("Data Validation").Sort.SortFields.Add Key:=Range(ColumnLetter(i) & "2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

            With Worksheets("Data Validation").Sort
                .SetRange Range(ColumnLetter(i) & "2:" & ColumnLetter(i) & sht2.Cells(sht2.Rows.Count, i).End(xlUp).Row)
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        Next i

        Application.ScreenUpdating = True

End Sub
Function ColumnLetter(colnum As Long) As String

    ColumnLetter = Split(Cells(1, colnum).Address, "$")(1)

End Function

An example of data in a column:

img1

\$\endgroup\$
4
  • \$\begingroup\$ Can you provide any sample data from the sheets? \$\endgroup\$
    – PeterT
    Jan 30, 2019 at 1:13
  • \$\begingroup\$ Funnily enough, I've been working on a data structure that achieves precisely this. Annoyingly it's still a work in progress, but the basic concept is that I encapsulate an ArrayList and raise events whenever the order or content change. You might be able to make use of the working branch though. Message me on chat if you'd like some more details, the whole thing will hopefully go up on CR fairly soon \$\endgroup\$
    – Greedo
    Jan 30, 2019 at 9:09
  • \$\begingroup\$ @PeterT I added a small example of what data in a column would look like. \$\endgroup\$
    – dwirony
    Jan 30, 2019 at 16:18
  • \$\begingroup\$ @Greedo Interesting - I'll take a look at this. Thanks. \$\endgroup\$
    – dwirony
    Jan 30, 2019 at 17:28

1 Answer 1

1
\$\begingroup\$

I would refactor your code and add Worksheets("Data Validation").Range("A1").Select to the end to clear the selection.

Refactored Code

Changes:

  • ColumnLetter(): Removed
  • sht2: Replaced using a With block.
  • For j: Changed to For item. item.Value is much easier to distinguish than sht.Cells(j, listcol).Value
  • .Range("A1").Select: Added to clear the dreaded selected column
  • Cell reference fully qualified for the Sort ranges (I am surprised that the code would run without Worksheets("Data Validation") being the ActiveSheet.
  • sht2.Range("A2:K500").ClearContents: Replaced made dynamic using sht2.Range("A1:K1").CurrentRegion.Offset(1).ClearContents

Sub PopulateAllDataValidationLists()
    Dim sht As Worksheet
    Dim i As Long, listcol As Long
    With Worksheets("Data Validation")
        Application.ScreenUpdating = False

        .Range("A1:K1").CurrentRegion.Offset(1).ClearContents
        Dim columnName As String
        Dim InvalidValues As Variant

        InvalidValues = Array("UNK", "xxx", "yyy", "zzz", "yxz", "zyx")

        Dim rColumn As Range, item As Range
        For i = 1 To 11
            columnName = .Cells(1, i).Value
            With Worksheets("Sheet 1")
                listcol = .Rows("1:1").Find(What:=columnName, LookAt:=xlWhole).Column
                Set rColumn = Range(.Cells(1, listcol), .Cells(.Rows.Count, listcol).End(xlUp))
            End With

            For Each item In rColumn
                If item.Value <> "" Then
                    If IsError(Application.Match(item.Value, .Columns(i), 0)) And _
                       IsError(Application.Match(item.Value, InvalidValues, 0)) And _
                       Len(item.Value) <= 3 Then
                        .Cells(.Cells(.Rows.Count, i).End(xlUp).Row + 1, i).Value = item
                    End If
                End If
            Next

            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=.Cells(2, i), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            Dim target As Range
            Set target = Range(.Cells(2, i), .Cells(.Rows.Count, i).End(xlUp))

            With .Sort
                .SetRange target
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        Next i
        .Range("A1").Select
    End With

    Application.ScreenUpdating = True

End Sub

Other Method

There are many ways that you can sort the data:

Here is an example of how you can use an ADODB.Recordset to create a table in memory to sort and potentially filter the data.

RSSort: Class

Option Explicit
Public FieldName As String
Private Const adVarChar = 200
Private Const adOpenKeyset = 1
Private Const adUseClient = 3
Private Const adLockPessimistic = 2
Private rs As Object

Private Sub Class_Initialize()
    FieldName = "Values"
    Set rs = CreateObject("ADODB.Recordset")

    With rs
        .Fields.Append FieldName, adVarChar, 255
        .CursorType = adOpenKeyset
        .CursorLocation = adUseClient
        .LockType = adLockPessimistic
        .Open
    End With
End Sub

Public Sub AddNew(ByVal item As Variant)
    rs.AddNew FieldName, item
End Sub

Public Property Get Filter() As String
    Filter = rs.Filter
End Property

Public Property Let Filter(ByVal sFilter As String)
    rs.Filter = sFilter
End Property

Public Sub Sort(Optional SortAscending As Boolean = True)
    rs.Sort = FieldName & IIf(SortAscending, " ASC", " DESC")
End Sub

Public Function ToArray() As Variant
    Dim data As Variant, results As Variant
    If rs.RecordCount = 0 Then
        ReDim results(1 To 1, 1 To 1)
        ToArray = results
        Exit Function
    End If
    rs.MoveFirst
    data = rs.GetRows(rs.RecordCount)
    ReDim results(1 To UBound(data, 2) + 1, 1 To 1)

    Dim r As Long

    For r = 1 To UBound(data, 2)
        results(r + 1, 1) = data(0, r)
    Next

    ToArray = results
End Function

Demo Code

Sub RSSorterPopulateAllDataValidationLists()
    Application.ScreenUpdating = False

    Dim data As Variant
    Dim c As Long

    With Worksheets("Data Validation")
        .Range("A1:K1").CurrentRegion.Offset(1).ClearContents
        For c = 1 To 11
            data = getValidationValues(.Columns(c), "", "UNK", "xxx", "yyy", "zzz", "yxz", "zyx")
            .Cells(2, c).Resize(UBound(data)).Value = data
        Next
    End With
End Sub

Function getValidationValues(MatchColumn As Range, ParamArray InvalidValues() As Variant) As Variant()
    Dim sorter As New RSSorter
    Dim col As Range
    Dim ColumnHeader As String
    ColumnHeader = MatchColumn.Cells(1, 1).Value
    Dim vExcluded As Variant
    vExcluded = InvalidValues

    With Worksheets("Sheet 1")
        Dim item As Range
        Set col = .Rows("1:1").Find(What:=ColumnHeader, LookAt:=xlWhole)
        If Not col Is Nothing Then
            For Each item In Range(col.Cells(2, 1), .Cells(.Rows.Count, col.Column).End(xlUp))
                If item.Value <> "" Then
                    If IsError(Application.Match(item.Value, MatchColumn, 0)) And _
                       IsError(Application.Match(item.Value, vExcluded, 0)) And _
                       Len(item.Value) <= 3 Then
                        sorter.AddNew item
                    End If
                End If
            Next
        End If
    End With
    sorter.Sort
    getValidationValues = sorter.ToArray
End Function

Edit

  • shtreplaced with With Worksheets("Sheet 1")
  • Constants (adOpenKeyset, adUseClient, adLockPessimistic) added to completely convert from early binding to late binding.
  • The ADODB library "Microsoft ActiveX Data Objects x.x Library" removed from original workbook
\$\endgroup\$
4
  • \$\begingroup\$ This is great! Is there a library that I need to use for RSSorter? Getting user-defined type not defined. \$\endgroup\$
    – dwirony
    Jan 30, 2019 at 17:32
  • \$\begingroup\$ Although I will say that the refactored code works nicely (except it was missing a Set line for sht which I easily added). Additionally, I had to get rid of Range("A1").Select since that sheet is hidden and not active when sorting - but it looks to run faster! \$\endgroup\$
    – dwirony
    Jan 30, 2019 at 17:35
  • \$\begingroup\$ @dwirony Thanks for accepting my answer. I resolved the issues(see edits). Late night \$\endgroup\$
    – TinMan
    Jan 30, 2019 at 18:45
  • \$\begingroup\$ Haha no worries - I was tired when this original script, I should've created an array and checked against it instead of all those Ands... sloppy by me. \$\endgroup\$
    – dwirony
    Jan 30, 2019 at 19:14

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.