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!
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.
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
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
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