How to remove leading and trailing spaces from all cells of a excel sheet at once - excel

I have a excel sheet which contains lots of data with leading and trailing spaces.
Manually removing these spaces with TRIM() takes lot of time.
How can I do this efficiently.

Try this small macro:
Sub KleanUp()
Dim r As Range
For Each r In ActiveSheet.UsedRange
v = r.Value
If v <> "" Then
If Not r.HasFormula Then
r.Value = Trim(v)
End If
End If
Next r
End Sub
This macro will not affect internal spaces or cells containing formulas.

To do this efficiently use a variant array, something like:
Sub VBATrim()
Dim rng1 As Range
Dim rngArea As Range
Dim lngRow As Long
Dim lngCol As Long
Dim lngCalc As Long
Dim X()
On Error Resume Next
Set rng1 = Application.InputBox("Select range for the replacement of non-number", "User select", Selection.Address, , , , , 8)
If rng1 Is Nothing Then Exit Sub
On Error GoTo 0
'Speed up the code by turning off screenupdating and setting calculation to manual
'Disable any code events that may occur when writing to cells
With Application
lngCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'Test each area in the user selected range
'Non contiguous range areas are common when using SpecialCells to define specific cell types to work on
For Each rngArea In rng1.Areas
'The most common outcome is used for the True outcome to optimise code speed
If rngArea.Cells.Count > 1 Then
'If there is more than once cell then set the variant array to the dimensions of the range area
'Using Value2 provides a useful speed improvement over Value. On my testing it was 2% on blank cells, up to 10% on non-blanks
X = rngArea.Value2
For lngRow = 1 To rngArea.Rows.Count
For lngCol = 1 To rngArea.Columns.Count
'replace the leading zeroes
X(lngRow, lngCol) = Trim(X(lngRow, lngCol))
Next lngCol
Next lngRow
'Dump the updated array sans leading zeroes back over the initial range
rngArea.Value2 = X
Else
'caters for a single cell range area. No variant array required
rngArea.Value = Trim(rngArea.Value)
End If
Next rngArea
'cleanup the Application settings
With Application
.ScreenUpdating = True
.Calculation = lngCalc
.EnableEvents = True
End With
End Sub

Related

Excel VBA - How to remove text of a certain color from every cell in a column

Edit: Now its working much better but the code starts deleting non-black text from other columns as well ?_? the code works for other worksheets so I'm not sure why it only doesn't work for this one... :"( pls help
I have an excel sheet with text that has multiple colors in the same cell e.g. blue and black words in the same cell. I want to remove all the blue words. I wrote a loop that loops through the cells and every character in the cells in the entire column and writes the black words back to each cell. However it takes a really long time so its not very feasible. Also I tried using arrays but I'm not sure how to store the format alongside the value into the array :"( Thanks!
Sub deletecommentsRight_New()
Dim lrow As Long
Dim textOut As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lrow = LastRow()
Range("M1:M" & lrow).Select
For Each Cell In Selection
textOut = ""
For i = 1 To Len(Cell)
If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
textOut = textOut & Mid(Cell, i, 1)
End If
Next
Cell.Value = textOut
Cell.Font.ColorIndex = 1
Next Cell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Public Function LastRow() As Long
'Finds the last non-blank cell on a sheet/range.
Dim lrow As Long
Dim lCol As Long
lrow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
LastRow = lrow
End Function
First of all, you should always use Option Explicit at the top of your modules so that it forces you to declare all variables properly.
There is no need to loop through an entire column. Only loop through cells that actually have values. For that we can use the Worksheet.UsedRange property and do an Intersect with the desired range.
Also code should be able to ignore errors and numbers since you are only interested in texts.
Also, there is no need to read the cell value multiple times so best is to read them just once using an array. A With construct can help in reading the cell font colors easily.
Here is what I came up with - kept the original method name:
Option Explicit
Public Sub DeleteComments(ByVal rng As Range)
Dim tempRng As Range
Dim tempArea As Range
Set tempRng = GetUsedRange(rng)
If tempRng Is Nothing Then Exit Sub
'Store app state and turn off some features
Dim scrUpdate As Boolean: scrUpdate = Application.ScreenUpdating
Dim calcMode As XlCalculation: calcMode = Application.Calculation
Dim evEnabled As Boolean: evEnabled = Application.EnableEvents
With Application
If .ScreenUpdating Then .ScreenUpdating = False
If calcMode <> xlCalculationManual Then .Calculation = xlCalculationManual
If .EnableEvents Then .EnableEvents = False
End With
'Loop through all areas. Check/update only relevant values
For Each tempArea In tempRng.Areas
If tempArea.Count = 1 Then
UpdateCell tempArea, tempArea.Value2
Else
Dim arr() As Variant: arr = tempArea.Value2 'Read whole range into array
Dim rowsCount As Long: rowsCount = tempArea.Rows.Count
Dim i As Long: i = 1
Dim j As Long: j = 1
Dim v As Variant
'For Each... loop is faster than using 2 For... Next loops on a 2D array
For Each v In arr 'Column-major order
If VarType(v) = vbString Then 'Only check strings - ignore numbers and errors
If Len(v) > 0 Then UpdateCell tempArea.Cells(i, j), v
End If
i = i + 1
If i > rowsCount Then 'Switch to the next column
j = j + 1
i = 1
End If
Next v
End If
Next tempArea
'Restore app state
With Application
If scrUpdate Then .ScreenUpdating = True
If calcMode <> xlCalculationManual Then .Calculation = calcMode
If evEnabled Then .EnableEvents = True
End With
End Sub
Private Function GetUsedRange(ByVal rng As Range) As Range
If rng Is Nothing Then Exit Function
On Error Resume Next
Set GetUsedRange = Intersect(rng, rng.Worksheet.UsedRange)
On Error GoTo 0
End Function
Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
Dim textOut As String
Dim charExcluded As Boolean
Dim i As Long
For i = 1 To Len(value)
With cell.Characters(i, 1).Font
If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
textOut = textOut & Mid$(value, i, 1)
Else
charExcluded = True
End If
End With
Next i
If charExcluded Then cell.Value2 = textOut
If IsNull(cell.Font.ColorIndex) Then
cell.Font.ColorIndex = 1
ElseIf cell.Font.ColorIndex <> 1 Then
cell.Font.ColorIndex = 1
End If
End Function
As you can see, I've split the code in a few auxiliary functions so that is easier to maintain.
To use it just call it on the desired range. For example:
DeleteComments Selection 'if you already have a selected range
'Or
DeleteComments Range("M:M") 'as in your original post
An added benefit is that this code works regardless if your desired range is a column, a row, multiple columns/rows or even multi-area ranges. Gives you a lot of flexibility and is as fast as you could make it.
Edit #1
The UpdateCell function could be faster if we only check cells with mixed colors:
Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
Dim textOut As String
Dim charExcluded As Boolean
Dim i As Long
If IsNull(cell.Font.ColorIndex) Then
For i = 1 To Len(value)
With cell.Characters(i, 1).Font
If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
textOut = textOut & Mid$(value, i, 1)
Else
charExcluded = True
End If
End With
Next i
If charExcluded Then cell.Value2 = textOut
cell.Font.ColorIndex = 1
ElseIf cell.Font.ColorIndex <> 1 Then
cell.Value2 = Empty
cell.Font.ColorIndex = 1
End If
End Function
You are doing this for over a million cells, most of them are empty. If you start by checking that the cell is not empty, you might heavily improve the performance.
Building on the suggestions provided, here is the modified code. Since the original code worked on selection, an option to ask the user to select a range is opted than defining fixed ranges.
Sub deletecomments()
Dim textOut As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'----------------------------
Dim myrange As Range
ThisWorkbook.Sheets("Sheet1").Activate 'Change Workbook and Sheet name accordingly
Set myrange = Application.InputBox(Title:="Range Selector", Prompt:="Please select your Range.", Type:=8)
'--------------------------
For Each Cell In myrange 'Replace selection with myRange
textOut = ""
For i = 1 To Len(Cell)
If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
textOut = textOut & Mid(Cell, i, 1)
End If
Next
Cell.value = textOut
Cell.Font.ColorIndex = 1
Next Cell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Applying a formula into an excel string

I want to add 50 to this the numeric portion in the middle of a string
I have 10000 strings to update.
All of these starts like Smart/, than comes the number.
Smart/6420/CD-Cases
would become
Smart/6470/CD-Cases
Thanks and appreciate the help if it is doable
Running a RegExp over a user selection with a variant array is a fast way to replace the results in-situ
Sub RegexReplace()
Dim rng1 As Range
Dim rngArea As Range
Dim lngRow As Long
Dim lngCol As Long
Dim lngCalc As Long
Dim objReg As Object
Dim lngTemp As Long
Dim X()
On Error Resume Next
Set rng1 = Application.InputBox("Select range for the replacement of leading zeros", "User select", Selection.Address, , , , , 8)
If rng1 Is Nothing Then Exit Sub
On Error GoTo 0
'See Patrick Matthews excellent article on using Regular Expressions with VBA
Set objReg = CreateObject("vbscript.regexp")
With objReg
.Pattern = "(Smart\/)(\d+)(.*)"
.ignorecase = True
.Global = False
End With
'Speed up the code by turning off screenupdating and setting calculation to manual
'Disable any code events that may occur when writing to cells
With Application
lngCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'Test each area in the user selected range
For Each rngArea In rng1.Areas
'The most common outcome is used for the True outcome to optimise code speed
If rngArea.Cells.Count > 1 Then
'If there is more than once cell then set the variant array to the dimensions of the range area
'Using Value2 provides a useful speed improvement over Value. On my testing it was 2% on blank cells, up to 10% on non-blanks
X = rngArea.Value2
For lngRow = 1 To rngArea.Rows.Count
For lngCol = 1 To rngArea.Columns.Count
lngTemp = CLng(objReg.Replace(X(lngRow, lngCol), "$2")) + 50
X(lngRow, lngCol) = objReg.Replace(X(lngRow, lngCol), "$1" & lngTemp & "$3")
Next lngCol
Next lngRow
'Dump the updated array back over the initial range
rngArea.Value2 = X
Else
'caters for a single cell range area. No variant array required
lngTemp = CLng(objReg.Replace(rngArea.Value, "$2")) + 50
rngArea.Value = objReg.Replace(rngArea.Value, "$1" & lngTemp & "$3")
End If
Next rngArea
'cleanup the Application settings
With Application
.ScreenUpdating = True
.Calculation = lngCalc
.EnableEvents = True
End With
Set objReg = Nothing
End Sub
The right solution depends on how much variation there is in your data. If they all start with "Smart/" and each number is 4 digits long, then the following would do what you want. I assume the data starts in A1. You could copy it down the 1000 rows you're dealing with.
=VALUE(MID(A1,7,4))+50
If there's variation, then you'll have to account for that by using FIND and LEN formulas to look for the / characters and trim the digit out. Here's an example: http://www.mrexcel.com/forum/excel-questions/444266-extract-string-between-two-characters.html.
If you have the option to use a macro, this would be much easier using VBA, where you could just use a Split function to split each value at the / character and grab the one in the middle. That would look something like this:
Public Sub AddFifty()
Dim rng As Range
Set rng = Range("A1:A1000")
Dim tmp() As String
For Each cell in rng.Cells
tmp = Split(cell.Value2, "/")
cell.Offset(0,1).Value2 = CLng(tmp(1)) + 50
Next cell
End Sub
Please try:
=MID(A1,1,FIND("/",A1))&MID(A1,FIND("/",A1)+1,LEN(A1)-FIND("/",A1,FIND("/",A1)+1)-4)+50&MID(A1,FIND("/",A1,FIND("/",A1)+1),LEN(A1)-FIND("/",A1))
as tested only on the single example provided.
Another option would be to use Text to Columns with / as the delimiter to split the source into three pieces, before adding 50 to the middle piece and then stitching everything back together again with CONCATENATE.

Find and replace inside a Cell [closed]

Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
Closed 8 years ago.
This question appears to be off-topic because it lacks sufficient information to diagnose the problem. Describe your problem in more detail or include a minimal example in the question itself.
Questions asking for code must demonstrate a minimal understanding of the problem being solved. Include attempted solutions, why they didn't work, and the expected results. See also: Stack Overflow question checklist
Improve this question
In my Excel file I have:
A
1 10-30
2 40-45
3 30-80
There can be any range of numbers separated by - in any cell.
In any particular column (might be any cell) i want to remove all text from the start to the - hyphen.
Example: 40-45 will be replaced with 45.
The below code will iterate through all worksheets and their used ranges ( all cells in all sheets in one workbook ) and replace any text that is separated by a - dash i.e 40-50 with only the second part of the string (50)
Sub Main()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim ws As Worksheet, ur As Range, r As Range
For Each ws In Sheets
Set ur = ws.UsedRange
For Each r In ur
On Error Resume Next
r = Split(r, "-")(1)
Next
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
You could also use the below
Sub MMain()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim ws As Worksheet, ur As Range, r As Range
For Each ws In Sheets
Set ur = ws.UsedRange
For Each r In ur
If Not IsEmpty(r) Then
If InStr(1, r.Text, "-", vbTextCompare) Then
r = Split(r, "-")(1)
End If
End If
Next
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
but in this particular case using the first example is about 50% faster then the second one.
I have tested it with 100,000 cells to check and split
Result for the first one: 2.31 sec
Result for the second one: 4.62 sec
Another approach is to use a regular expression to be selective on the replacement
This code will prompt you for a range to operate on.
Sub Update()
Dim rng1 As Range
Dim rngArea As Range
Dim lngRow As Long
Dim lngCol As Long
Dim lngCalc As Long
Dim objReg As Object
Dim X()
On Error Resume Next
Set rng1 = Application.InputBox("Select range for the replacement of leading zeros", "User select", Selection.Address, , , , , 8)
If rng1 Is Nothing Then Exit Sub
On Error GoTo 0
Set objReg = CreateObject("vbscript.regexp")
objReg.Pattern = "\d+\-(\d+)"
'Speed up the code by turning off screenupdating and setting calculation to manual
'Disable any code events that may occur when writing to cells
With Application
lngCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'Non contiguous range areas are common when using SpecialCells to define specific cell types to work on
For Each rngArea In rng1.Areas
'The most common outcome is used for the True outcome to optimise code speed
If rngArea.Cells.Count > 1 Then
'If there is more than once cell then set the variant array to the dimensions of the range area
'Using Value2 provides a useful speed improvement over Value. On my testing it was 2% on blank cells, up to 10% on non-blanks
X = rngArea.Value2
For lngRow = 1 To rngArea.Rows.Count
For lngCol = 1 To rngArea.Columns.Count
'replace text
X(lngRow, lngCol) = objReg.Replace(X(lngRow, lngCol), "$1")
Next lngCol
Next lngRow
'Dump the updated array sans leading whitepace back over the initial range
rngArea.Value2 = X
Else
'caters for a single cell range area. No variant array required
rngArea.Value = objReg.Replace(rngArea.Value, "$1")
End If
Next rngArea
'cleanup the Application settings
With Application
.ScreenUpdating = True
.Calculation = lngCalc
.EnableEvents = True
End With
Set objReg = Nothing
End Sub

Remove all but numbers from cell and cut off numbers after dash

I have a row that contains part of an address example "GILBERT AZ 85234-4512". I want to remove all but the 85234. So remove all characters but numbers and only keep the 5 digit zip.
This needs to be done in a loop because I have 1500+ records. If it's not too much trouble have it remove any left over spaces too.
This would be done most efficiently with a RegExp and a variant array (as range loops can be very slow)
From this article
Sub KillNums()
Dim rng1 As Range
Dim rngArea As Range
Dim lngRow As Long
Dim lngCol As Long
Dim lngCalc As Long
Dim objReg As Object
Dim X()
On Error Resume Next
Set rng1 = Application.InputBox("Select range for the replacement of leading zeros", "User select", Selection.Address, , , , , 8)
If rng1 Is Nothing Then Exit Sub
On Error GoTo 0
'See Patrick Matthews excellent article on using Regular Expressions with VBA
Set objReg = CreateObject("vbscript.regexp")
objReg.Pattern = "^.+?(\d+)\-.*$"
'Speed up the code by turning off screenupdating and setting calculation to manual
'Disable any code events that may occur when writing to cells
With Application
lngCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'Test each area in the user selected range
'Non contiguous range areas are common when using SpecialCells to define specific cell types to work on
For Each rngArea In Intersect(rng1, ActiveSheet.UsedRange).Areas
'The most common outcome is used for the True outcome to optimise code speed
If rngArea.Cells.Count > 1 Then
'If there is more than once cell then set the variant array to the dimensions of the range area
'Using Value2 provides a useful speed improvement over Value. On my testing it was 2% on blank cells, up to 10% on non-blanks
X = rngArea.Value2
For lngRow = 1 To rngArea.Rows.Count
For lngCol = 1 To rngArea.Columns.Count
'replace the leading zeroes
X(lngRow, lngCol) = objReg.Replace(X(lngRow, lngCol), "$1")
Next lngCol
Next lngRow
'Dump the updated array back over the initial range
rngArea.Value2 = X
Else
'caters for a single cell range area. No variant array required
rngArea.Value = objReg.Replace(rngArea.Value, "$1")
End If
Next rngArea
'cleanup the Application settings
With Application
.ScreenUpdating = True
.Calculation = lngCalc
.EnableEvents = True
End With
Set objReg = Nothing
End Sub
Unless there is a "-" in the address elsewhere, this should work.
updated: I altered this for cases with no "-" in the zipcodes
Sub findZip()
Dim hyphen As String
Dim zip As String
For Each cell In Range("A2:A1501")
hyphen = InStr(1, cell, "-")
If hyphen <> 0 Then
zip = Trim(Mid(cell, hyphen - 5, 5))
Else: zip = Right(Trim(cell), 5)
End If
cell.Offset(0, 1) = zip
Next
End Sub
A quick way is to select the cells and choose Find-Replace (Ctrl+H).
First replace -* with nothing and then replace *  (inc. blank space) with nothing .
This relies on your data being consistently formatted so check the results and use undo/redo if necessary.

Select all Cells at once above limit value

I can Select only the Cells with in region that contain numbers:
Region.SpecialCells(xlCellTypeConstants , xlNumbers)
but I don't know how to Select only the cells that are above a number. For example those above 1.0
I have a big Sheet with numbers and I want to cap all numbers above 1, and set them to 1. I would love to do it without having to loop on each cell.
thanks!
This method below avoids the cell by cell loop - while it is significantly longer than your range loop code I share your preference for avoiding cell by cell range loops where possible
I have updated my code from A fast method for determining the unlocked cell range to provide a non cell by cell loop method
the code checks that SpecialCells(xlCellTypeConstants , xlNumbers)
exist on the sheet to be updated (error handling should always be
used with SpecialCells
if these cells exist, a working sheet is created, and a formula is inserted into the range from step 1 to create a deliberate error (the 1/0) if the value on the main sheet is >1
SpecialCells(xlCellTypeFormulas, xlErrors) returns a range of cells from the working sheet where the values were greater than 1 (into rng3)
All areas in rng3 are set to 1 with rng3.Value2=1
Sub QuickUpdate()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim lCalc As Long
Set ws1 = ActiveSheet
On Error Resume Next
Set rng1 = ws1.Cells.SpecialCells(xlConstants, xlNumbers)
On Error GoTo 0
'exit if there are no contants with numbers
If rng1 Is Nothing Then Exit Sub
'disable screenupdating, event code and warning messages.
'set calculation to manual
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lCalc = .Calculation
.Calculation = xlCalculationManual
End With
ws1.Copy After:=Sheets(Sheets.Count)
Set ws2 = ActiveSheet
'test for cells constants > 1
ws2.Cells.SpecialCells(xlConstants, xlNumbers).FormulaR1C1 = "=IF('" & ws1.Name & "'!RC>1,1/0,'" & ws1.Name & "'!RC)"
On Error Resume Next
Set rng2 = ws2.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rng2 Is Nothing Then
Set rng3 = ws1.Range(rng2.Address)
rng3.Value2 = 1
Else
MsgBox "No constants < 1"
End If
ws2.Delete
'cleanup user interface and settings
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
lCalc = .Calculation
End With
'inform the user of the unlocked cell range
If Not rng3 Is Nothing Then
MsgBox "Cells updated in Sheet " & vbNewLine & ws1.Name & vbNewLine & " are " & vbNewLine & rng3.Address(0, 0)
Else
MsgBox "No cells updated in " & ws1.Name
End If
End Sub
I say, forget about SpecialCells. Just load all cells that need testing into a Variant array. Then loop over that array and do your capping. That is very efficient, contrary to looping over cells in a sheet. Finally, write it back to the sheet.
With 50,000 cells containing random values between 0 and 2, this code ran in 0.2 s on my antique laptop.
The added bonus is that this is quite clear and readable code, and you retain full control over what range will be operated on.
Dim r As Range
Dim v As Variant
Set r = Sheet1.UsedRange
' Or customise it:
'Set r = Sheet1.Range("A1:HZ234") ' or whatever.
v = r ' Load cells to a Variant array
Dim i As Long, j As Long
For i = LBound(v, 1) To UBound(v, 1)
For j = LBound(v, 2) To UBound(v, 2)
If IsNumeric(v(i, j)) And v(i, j) > 1 Then
v(i, j) = 1 ' Cap value to 1.
End If
Next j
Next i
r = v ' Write Variant array back to sheet.
What is the harm in looping? I just tested this code on a range of 39900 cells and it ran in 2 Secs.
Sub Sample()
Dim Rng As Range, aCell As Range
Set Rng = Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
For Each aCell In Rng
If aCell.Value > 1 Then aCell.Value = 1
Next aCell
End Sub
My only concern is the use of SpecialCells as they are unpredictable and hence I rarely use them.
Also have a look at this KB article: http://support.microsoft.com/?kbid=832293

Resources