0

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.

5
  • Low hanging fruit: Size the array in advance (if you are unsure of actual size then oversize it with a guessestimate and do a single redim at end - using a counter so you know what size to redim to. You will need to transpose the array if redimming the rows, then transpose again though) Commented Apr 19, 2020 at 17:26
  • You can also remove columns, insert columns within an array rather than in a sheet (have an input output mapping for columns of interest) Commented Apr 19, 2020 at 17:28
  • Would you be able to use a VBA library written in C#. You just copy a couple of files to a directory and then in the VBA IDE reference the library using Tools.References.Browse. The source code for the library is open source. Commented Apr 19, 2020 at 17:55
  • That looks fine to me - except Ar/Arr is almost the most confusing naming for your two arrays... If you step backwards through the columns then it would be slightly more efficient, since you'd be removing columns starting from the right instead of the left. Still, with only 5k rows and 15 columns this would be very quick anyway. For cleanliness I'd be inclined to factor out the "remove column" function into a separate method. Commented Apr 19, 2020 at 18:17
  • Consider range copy/delete methods in the Object Model, which may be faster when doing bulk column/row ops. For this particular operation it's faster just copying the ranges over, either then deleting columns, or previously joining the ranges that should be copied. Commented Apr 21, 2020 at 20:07

2 Answers 2

3

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
Sign up to request clarification or add additional context in comments.

Comments

0

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

Comments

Your Answer

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

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.