Home » excel » Excel VBA – Looking for ways to simplify loop

Excel VBA – Looking for ways to simplify loop

Posted by: admin May 14, 2020 Leave a comment

Questions:

I recently made a loop that takes the string in each cell, searches for a “_” in the string, and if there is one cuts off that bit and any character after it. Looking at the code I realized it might be too elaborate and could be shortened or simplified, but I’m not quite sure how to do so. Is there a way to make this bit of code more efficient?

Sub Name_Change()

Sheets("Sheet1").Activate

Dim tg_row As Integer
tg_row = 1

For Each nm_cl In Range("Table1[Name]")
    If InStr(1, nm_cl, "_", vbTextCompare) = 0 Then
        Range("Table1[Name]").Cells(tg_row, 1).Value = nm_cl.Value
    Else
        Range("Table1[Name]").Cells(tg_row, 1) = _
                Left(nm_cl, InStr(1, nm_cl, "_", vbTextCompare) - 1)
    End If
    tg_row = tg_row + 1
Next nm_cl

End Sub

Thank you for your help!

How to&Answers:

A first attempt at optimizing this would be to note that you are calling InStr multiple times. You can speed things up by computing it once, and storing the result.

Along with that I would note that presumably Range("Table1[Name]") only has one column (otherwise you would be overwriting the first column with data from the other columns). So, you can replace Range("Table1[Name]").Cells(tg_row, 1) with nm_cl. In doing this, we notice the redundant statement of nm_cl.Value = nm_cl.Value can be removed. This leads to the following code:

Sub Name_Change()

Sheets("Sheet1").Activate

Dim index As Long

For Each nm_cl In Range("Table1[Name]")
    index = InStr(1, nm_cl, "_", vbTextCompare)
    If index <> 0 Then
        nm_cl = Left(nm_cl, index - 1)
    End If
Next nm_cl

End Sub

If you need more efficiency, beyond this, you can load your data into a variant by using

dim data as Variant
data = Range("Table1[Name]").Value

process all of your data within VBA, and then put it back to the worksheet using

Range("Table1[Name]").Value = data

This will increase your speed, as transfering data between Excel and VBA is slow and this means you will have 1 read and 1 write, instead of 1 read and 1 write per line, but it will require a (minor) rewrite of your algorithm as the syntax for working with an array within a variant is different from working with ranges. Note that this will not work if you go beyond the 65536 rows. I beleive that it is a legacy constraint from Excel 2003 and earlier.

Answer:

You could adjust your loop to only modify the cells that contain “_”.

If Not InStr(1, nm_cl, "_", vbTextCompare) = 0 Then
    Range("Table1[Name]").Cells(tg_row, 1) = _
            Left(nm_cl, InStr(1, nm_cl, "_", vbTextCompare) - 1)
End If

EDIT:

Here’s a working example that includes @Degustaf’s suggestions. Just change the name of the range to fit your worksheet.

Sub Name_Change()

Dim selectedRange As Range
Dim rangeData As Variant 'Array containing data from specified range
Dim col As Long 'Selected column from range
Dim row As Long 'Selected row from range
Dim cellValue As String 'Value of selected cell
Dim charPosition As Long 'Position of underscore

Sheets("Sheet1").Activate

Set selectedRange = Range("YOUR-NAMED-RANGE-HERE")

If selectedRange.Columns.Count > 65536 Then
    MsgBox "Too many columns!", vbCritical
ElseIf selectedRange.Rows.Count > 65536 Then
    MsgBox "Too many rows!", vbCritical
Else
    rangeData = selectedRange.Value
    If UBound(rangeData, 1) > 0 And UBound(rangeData, 2) > 0 Then
        'Iterate through rows
        For row = 1 To UBound(rangeData, 1)
            'Iterate through columns
            For col = 1 To UBound(rangeData, 2)
                'Get value of cell
                cellValue = CStr(rangeData(row, col))
                'Get position of underscore
                charPosition = InStr(1, cellValue, "_", vbTextCompare)
                'Update cell data stored in array if underscore exists
                If charPosition <> 0 Then
                    rangeData(row, col) = Left(cellValue, charPosition - 1)
                End If
            Next col
        Next row
        'Overwrite range with array data
        selectedRange.Value = rangeData
    End If
End If

End Sub

Answer:

You could use a user defined function to return the truncated strings in cells.
The Worksheet-function could look like:

 Public function truncateAt( s as String) as string
     dim pos as integer         
     pos = instr (1, s,"_")
     If pos> 0 then
         truncateAt= left (s, pos)
     Else
         truncateAt= s
     End If
 End function