Array processing VBA

Question

i'm prototyping a solution for a tidious task using vba because my company's security only allows this method, can't use python nor anything else.

i have a table of 5K+ rows and about 15 columns, and i want to process it removing specific columns based on a search criteria.

so here's my code so far

Sub RstCr()

Dim Sh As Worksheet
Dim Ar() As Variant
Dim Arr As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim p As Integer

Set Sh = Sheets("Sheet1")

Sh.Cells(1, 1).CurrentRegion.Select

Ar = Sh.Range("A1").CurrentRegion.Value
MsgBox UBound(Ar, 1)
Arr = Array("COFOR", "Tri", "Fournisseur", ".Tiers.All", "GrM")


For i = 0 To UBound(Arr)
   For j = 1 To UBound(Ar, 2)
    If Ar(1, j) = Arr(i) Then
     For k = j To UBound(Ar, 2) - 1
      For p = 1 To UBound(Ar, 1)
         Ar(p, k) = Ar(p, k + 1)
      Next p
     Next k
    End If
   Next j
   ReDim Preserve Ar(UBound(Ar, 1), UBound(Ar, 2) - 1)
 Next i

 Worksheets("Sheet2").Range("A1").Resize(UBound(Ar, 1) , UBound(Ar, 2)).Value = Ar


 End Sub

My question is: how would an experienced vba developper rate this code, how efficient is it. Also, is there a better way to prcessing arrays other than the tetris approach (for example, to delete a column nothing works other than the method above).

the program has more tasks: - Inserting columns between specific columns - filling those columns with values available in another table containing corresponding values of cells in the first array - removing duplicates based on two columns - sorting array rows based on one column.

would continuing with the current approach still make sense or there is a better and easier way to do it.

Thank you.

Answer 1

You might want to consider using the worksheet/range properties & methods directly. Usually it can be faster to use arrays, but in this case there is some sort of recalculation of the arrays every time!

Function DeleteCol(r As Range, colName As String) As Long
    Dim i As Long
    For i = 1 To r.Columns.Count
        If r.Cells(1, i).Value = colName Then
            r.Columns(i).Delete XlDeleteShiftDirection.xlShiftToLeft
            DeleteCol = i
            Exit Function
        End If
    Next i
End Function

Sub test()        
    Dim r As Range
    Set r = Sheet1.Cells(1, 1).CurrentRegion
    r.Copy Sheet2.Cells(1, 1)

    Dim colNames() As Variant
    colNames = Array("B", "M", "O") 'use your column names here!!
    Dim n
    For Each n In colNames
        Dim i As Long
        i = DeleteCol(Sheet2.Cells(1, 1).CurrentRegion, CStr(n))
    Next n
End Sub

Answer 2

After a while that nested loop approach is going to get hard to follow. If you plan on doing much of this type of processing then you really need to reduce the volume of code in your main method and make it easier to follow. The code below might seem over-worked, but the smaller re-usable parts only get written once, then you can re-use them as needed from other parts of your code.

Now your main sub now only does one thing, and you can much more easily read the code to figure out what that is.

Sub ReworkMyData()

    Dim data, terms

    data = Sheets("Sheet1").Range("A1").CurrentRegion.Value
    terms = Array("COFOR", "Tri", "Fournisseur", ".Tiers.All", "GrM")

    RemoveMatchingColumns data, terms

    ArrayToSheet data, Worksheets("Sheet2").Range("A1")

End Sub

'remove all "columns" from data where the header matches an item in
'  the array "headers"
Sub RemoveMatchingColumns(data, headers)
    Dim i As Long
    i = UBound(data, 2)
    Do
        If Not IsError(Application.Match(data(1, i), headers, 0)) Then
            RemoveColumn data, i
            i = i - 1 'account for the removed column
        End If
        i = i - 1
    Loop While i > 0
End Sub

'remove a column at position "colNum"
Sub RemoveColumn(data, colNum As Long)
    Dim r As Long, c As Long
    For r = 1 To UBound(data, 1)
        For c = colNum To UBound(data, 2) - 1
            data(r, c) = data(r, c + 1)
        Next c
    Next r
    ReDim Preserve data(1 To UBound(data, 1), 1 To UBound(data, 2) - 1)
End Sub

Sub ArrayToSheet(data, rng As Range)
    With rng(1).Resize(UBound(data, 1), UBound(data, 2))
        .Value = data
    End With
End Sub