I have a macro that trims all cells in the currently selected column, when I use it on normal text, names, postcodes etc it works just fine, but when its used to trim an email address column it isn't removing trailing spaces.
' This needs trimming ' becomes 'This needs trimming' but
'thisneeds#trimming.to ' stays as 'thisneeds#trimming.to '.
This is the macro,
Dim mycell
mycell = ActiveCell.Address
ActiveCell.EntireColumn.Select
response = MsgBox("Are you sure you want to trim column " & Split(mycell, "$")(1) & "?", vbYesNo)
If response = vbNo Then
Exit Sub
End If
Dim arrData() As Variant
Dim arrReturnData() As Variant
Dim rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long
lRows = Selection.Rows.Count
lCols = Selection.Columns.Count
ReDim arrData(1 To lRows, 1 To lCols)
ReDim arrReturnData(1 To lRows, 1 To lCols)
Set rng = Selection
arrData = rng.Value
For j = 1 To lCols
For i = 1 To lRows
arrReturnData(i, j) = Trim(arrData(i, j))
Next i
Next j
rng.Value = arrReturnData
Set rng = Nothing
Range(mycell).Select
I can't understand why it works for every column but not email addresses.
You can get by without reinventing the wheel.
Please use this function as sample code to proceed.
Public Function TrimStr(inputStr As String) As String
TrimStr = WorksheetFunction.Trim(inputStr)
End Function
I have tried it with your example and others, and all sorts of spaces are removed.
Related
Is there a clean and tidy way to get cells split ONLY by sheet name? I have a bunch of cells that look something like this.
=(Xlookup($A2,Staff!A:A,Client!K:K)*E2
=B3*(Xlookup(E3,Auto!1:1,Desc!3:3)
And, all kinds of other stuff. Basically, I am trying to parse out only the sheet names from each cell. Each sheet name ends with a '!' character. So, I am trying to split one cell into multiple columns, based on the '!' character, and ignore any text that is not a sheet name. I tested the script below, but all it does is a basic split from one cell into multiple columns, which includes the sheet name, but all kinds of superfluous text, which I don't want.
Sub SplitData()
Const SrcCol = 1 ' A
Const TrgCol = 2 ' B
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim TheVal As String
Dim TheArr As Variant
Dim Num As Long
Application.ScreenUpdating = False
TrgRow = 1
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
TheVal = Cells(SrcRow, SrcCol).Value
TheArr = Split(TheVal, ",")
Num = UBound(TheArr) + 1
Cells(TrgRow, TrgCol).Resize(ColumnSize:=Num).Value = TheArr
TrgRow = TrgRow + 1
Next SrcRow
Application.ScreenUpdating = True
End Sub
Now:
Desired:
If you have O365, this will work for you ...
=LET(x, TRANSPOSE(FILTERXML("<d><r>" & SUBSTITUTE(A1, ",", "</r><r>") & "</r></d>", "//r[contains(text(),""!"")]")), MID(x, 1, FIND("!", x)))
... here's hoping you do, a lot easier.
Alternatively, I created my own VBA routine with the assumption that everything to the right of the formula is free to load into, just adjust for errors, names, performance, etc. as required ...
Public Sub GetWorksheets()
Dim lngRow As Long, lngColumn As Long, strFormula As String
Dim arrFormula() As String, i As Long, arrSubFormula() As String
With Sheet1
For lngRow = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
strFormula = Trim(.Cells(lngRow, 1))
lngColumn = 2
If strFormula <> "" Then
arrFormula = Split(strFormula, "!")
For i = 0 To UBound(arrFormula) - 1
arrSubFormula = Split(arrFormula(i), ",")
strFormula = arrSubFormula(UBound(arrSubFormula)) & "!"
.Cells(lngRow, lngColumn) = strFormula
lngColumn = lngColumn + 1
Next
End If
Next
End With
End Sub
I'm trying to use the split() function to loop through a specified range and split all strings when a ":" is encountered, and replace the existing value with the split value.
Dim k As Integer
Dim lRow as Long
Dim startZip_col As Long
Dim startZip_str As String
Dim startZip_result() As String
Dim startZip_decomposed As Variant
For k = 2 To lRow
startZip_str = Cells(k, startZip_col).Value
startZip_result = Split(startZip_str, ":")
For Each startZip_decomposed In startZip_result
Cells(k, startZip_col) = startZip_result(1)
Next
Next k
a example of the values i want to split are:
abc:1234
abc:5678
def:3456
tried debug.print to pinpoint where the errors are, but column value is correctly identified, loop looks fine, not sure where went wrong
Logic:
Where is lRow. startZip_col inititalized? Define and initialize your variables/Objects correctly.
Fully qualify the cells else it may refer to active sheet which may not be the sheet you think it is. For example ws.Cells(k, startZip_col).Value where ws is the relevant worksheet.
Before splitting, check for the existence of :
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim ZipCol As Long
Dim ZipString As String
Dim ZipResult As Variant
'~~> Change this to the relevant sheet
Set ws = Sheet1
'~~> Change this to the releavant column
ZipCol = 1
With ws
'~~> Get the last row in Col A. Change to relevant column
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
ZipString = .Cells(i, ZipCol).Value
'~~> Check if the string contains ":"
If InStr(1, ZipString, ":") Then
ZipResult = Split(ZipString, ":")
'.Cells(1, ZipCol) = ZipResult(1)
'~~> For testing
For j = LBound(ZipResult) To UBound(ZipResult)
Debug.Print ZipResult(j)
Next j
End If
Next i
End With
End Sub
I'm trying to copy the values of a range of cells(A1:A50) into a single cell (B1). I can do it manually by copying the cells to the clipboard and then pasting the clipboard into the formuala bar of B1 but I can't find a way of doing this in a macro other than getting the cells copied to the clipboard.
Hopefully someone can help me out here.
Sheet1.Range("A1:A50").SpecialCells(xlCellTypeConstants).Select
Selection.Copy
I would like the contents of cell B1 to look something like this:
Value of cell A1
Value of cell A2
Value of cell A3
...and so on
Just
Sub myConcat(rSource As Range, rTarget As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
rTarget.Value = Right(sRes, Len(sRes) - Len(sDelimiter))
End Sub
Call it from your code like as
Sub tst_myConcat()
Call myConcat([A1:A50], [B1])
End Sub
Of course, this procedure can be easily converted to a function:
Function myConcat(rSource As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
myConcat = Right(sRes, Len(sRes) - Len(sDelimiter))
End Function
In this case, just write in the target cell (B1) =myConcat(A1:A50)
Do not forget to include in the cell format Wrap text!
First Column To String
The FirstColumnToString function (UDF) has a fixed delimiter (Delimiter) which can manually be changed. But it can e.g. do the following:
=FirstColumnToString(A1:A2,A4,A6:C8,Sheet2!A1:A3)
where it will discard error values and zero-length strings ("") and choose only values from the first column of each range e.g. in range A6:C8 it will choose the values from A6:A8.
The Code
Option Explicit
Function FirstColumnToString(ParamArray SourceRanges() As Variant) _
As String
Const Delimiter As String = vbLf & vbLf
Dim RangesCount As Long
RangesCount = UBound(SourceRanges) - LBound(SourceRanges) + 1
Dim data As Variant
ReDim data(1 To RangesCount)
Dim Help As Variant
ReDim Help(1 To 1, 1 To 1)
Dim Element As Variant
Dim RowsCount As Long
Dim j As Long
For Each Element In SourceRanges
j = j + 1
If Element.Rows.Count > 1 Then
data(j) = Element.Columns(1).Value
Else
data(j) = Help
data(j)(1, 1) = Element.Columns(1).Value
End If
RowsCount = RowsCount + UBound(data(j))
Next Element
Dim Result As Variant
ReDim Result(1 To RowsCount)
Dim Current As Variant
Dim i As Long
Dim k As Long
For j = 1 To RangesCount
For i = 1 To UBound(data(j))
Current = data(j)(i, 1)
If Not IsError(Current) Then
If Current <> vbNullString Then
k = k + 1
Result(k) = Current
End If
End If
Next i
Next j
ReDim Preserve Result(1 To k)
FirstColumnToString = Join(Result, Delimiter)
End Function
A much simpler way of doing the job is to use the TREXTJOIN function in Excel:
With Sheet2.Range("A1:A50")
.AutoFilter Field:=1, Criteria1:="<>"
Sheet2.Range("B1").Value2 = WorksheetFunction.TextJoin(vbCrLf, True, _
.SpecialCells(xlCellTypeVisible))
.AutoFilter
End With
I'm trying to parse a column that contains data in the following format in each cell -
pull: test1
or
pull: test2|pull: test3|.....
or
other: blah...
I only want a grab each "Pull: test" and place 1 in each row in a new worksheet like below, and ignore any parts of the cell that don't begin with "pull: " -
pull: test1
pull: test2
pull: test3
...
What I have so far just pulls the entire column and pastes into the same spreadsheet, I'm not sure how to separate the items in each cell into their own rows. I also can't get it to pull to a different worksheet correctly either (commented out my attempt)
Sub InStrDemo()
Dim lastrow As Long
Dim i As Integer, icount As Integer
'Sheets.Add.Name = "TEST"
lastrow = ActiveSheet.Range("A10000").End(xlUp).Row
For i = 1 To lastrow
If InStr(1, LCase(Range("E" & i)), "pull:") <> 0 Then
icount = icount + 1
'Sheets("TEST").Range("A" & icount & ":E" & icount) = Worksheets("SearchResults").Range("A" & i & ":E" & i).Value
Range("L" & icount) = Range("E" & i).Value
End If
Next i
End Sub
Untested, written on mobile.
Option Explicit
Sub testDemo()
Dim sourceSheet as worksheet
Set sourceSheet = ActiveSheet ' would be more reliable to qualify the workbook and worksheet by name'
Dim outputSheet as worksheet
Set outputSheet = thisworkbook.worksheets.add
Dim lastRow As Long
lastrow = sourceSheet.Range("A10000").End(xlUp).Row
' I assume column E needs to be parsed'
Dim arrayOfValues() as variant
arrayOfValues = sourceSheet.range("E1:E" & lastRow)
Dim rowIndex as long
Dim columnIndex as long
Dim splitString() as string
Dim cumulativeOffset as long
Dim toJoin(0 to 1) as string
toJoin(0) = "pull: test" ' Might speed up string concatenation below'
Dim outputArray() as string
With outputsheet.range("A1") ' The first row you want to start stacking from'
For rowIndex = 1 to lastRow
' Single dimensional, 0-based array'
splitString = VBA.strings.split(vba.strings.lcase$(arrayOfValues(rowIndex,1)), "pull: test",-1, vbbinarycompare)
Redim outputArray(1 to (ubound(splitString)+1), 1 to 1)
For columnIndex = lbound(splitString) to ubound(splitString)
toJoin(1) = splitString(columnIndex)
Outputarray(columnIndex+1,1) = VBA.strings.join(toJoin, vbnullstring)
Next columnIndex
'Instead of splitting upon a delimiter, then prepending the delimiter to each array element (as is done above), you could repeatedly call instr(), use mid$() to extract the sub-string, then increase the argument passed to the "Start" parameter in instr() (effectively moving from start to end of the string) -- until instr() returns 0. Then move on to the next string in the outer loop.'
.offset(cumulativeOffset,0).resize(Ubound(outputArray, 1), 1).value2 = outputArray
cumulativeOffset = cumulativeOffset + ubound(splitString)
Next rowIndex
End Sub
I have this bit of code below that is very close to what I am looking to do. How it works is you press the “List Word Issue” button in the excel spreadsheet and it scans all the text, cell by cell and row by row in column A, against a separate worksheet containing a list of words. If there is a match (between what’s in each individual cell in column 1) then it puts the word(s) that match into the adjacent row in column b.
Here (http://mintywhite.com/more/software-more/microsoft-excel-analyze-free-text-surveys-feedback-complaints-part-2) is a link to the article that I found the code on and a link (http://mintywhite.com/wp-content/uploads/2011/02/wordcount2.xls) to download the entire .xls spreadsheet.
What I am looking for is a simple change so there will not be a “match” unless the word appears at least 5 times in each cell/row in column A of the first worksheet.
Sub WordCount()
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
ElementCounter = 2 'setting a default value for the counter
Worksheets(1).Activate
For Each rngCell In Worksheets("Word").Range("A3", Cells(Rows.Count, "A").End(xlUp))
vArray = Split(rngCell.Value, " ") 'spliting the value when there is a space
vrWordIssue = ""
ElementCounter = ElementCounter + 1 'increases the counter every loop
For lngLoop = LBound(vArray) To UBound(vArray)
If Application.WorksheetFunction.CountIf(Sheets("Issue").Range("A2:A" & Sheets("Issue").UsedRange.Rows.Count), vArray(lngLoop)) > 0 Then 'this is to test if the word exist in the Issue Sheet.
If vrWordIssue = "" Then
vrWordIssue = vArray(lngLoop) 'assigning the word
Else
If InStr(1, vrWordIssue, vArray(lngLoop)) = 0 Then 'a binary of comparison
vrWordIssue = vrWordIssue & ", " & vArray(lngLoop) 'this will concatinate words issue that exist in Issue Sheet
End If
End If
End If
Next lngLoop
Worksheets("Word").Range("B" & ElementCounter).Value = vrWordIssue 'entering the final word issue list into cell.
Next rngCell
End Sub
Quick comment about some of the code, if you're interested:
Dim lngLoop, lngLastRow As Long
lngLoop is actually Variant, not a long. Unfortunately, you cannot declare data types like this as you can in, say, C++.
You need to do this instead:
Dim lngLoop As Long, lngLastRow As Long
Also, WordIssue is never used. It is supposed to be vrWordIssue.
In fact, I would almost never use Variant for anything in VBA. I don't believe this author of that website knows a good amount of VBA. (at least, not when they wrote that)
That said, the first thing I would fix are the variables:
From:
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
To:
Dim vArray As Variant
Dim vrWordIssue As String
Dim ElementCounter As Long
Dim lngLoop As Long, lngLastRow As Long
Dim rngCell As Range, rngStoplist As Range
And add Option Explicit to the top of the module. This will help with debugging.
...And you don't almost never have to use Activate for anything...
....you know what? I would just use a different approach entirely. I don't like this code to be honest.
I know it's not encouraged to provide a full-blown solution, but I don't like not-so-good code being spread around like that (from the website that Douglas linked, not necessarily that Douglas wrote this).
Here's what I would do. This checks against issue words with case-sensitivity, by the way.
Option Explicit
Public Type Issues
Issue As String
Count As Long
End Type
Const countTolerance As Long = 5
Public Sub WordIssues()
' Main Sub Procedure - calls other subs/functions
Dim sh As Excel.Worksheet
Dim iLastRow As Long, i As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Worksheets("Word")
theIssues = getIssuesList()
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
' loop through worksheet Word
For i = 3 To iLastRow
Call evaluateIssues(sh.Cells(i, 1), theIssues)
Call clearIssuesCount(theIssues)
Next i
End Sub
Private Function getIssuesList() As Issues()
' returns a list of the issues as an array
Dim sh As Excel.Worksheet
Dim i As Long, iLastRow As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Sheets("Issue")
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
ReDim theIssues(iLastRow - 2)
For i = 2 To iLastRow
theIssues(i - 2).Issue = sh.Cells(i, 1).Value
Next i
getIssuesList = theIssues
End Function
Private Sub clearIssuesCount(ByRef theIssues() As Issues)
Dim i As Long
For i = 0 To UBound(theIssues)
theIssues(i).Count = 0
Next i
End Sub
Private Sub evaluateIssues(ByRef r As Excel.Range, ByRef theIssues() As Issues)
Dim vArray As Variant
Dim i As Long, k As Long
Dim sIssues As String
vArray = Split(r.Value, " ")
' loop through words in cell, checking for issue words
For i = 0 To UBound(vArray)
For k = 0 To UBound(theIssues)
If (InStr(1, vArray(i), theIssues(k).Issue, vbBinaryCompare) > 0) Then
'increase the count of issue word
theIssues(k).Count = theIssues(k).Count + 1
End If
Next k
Next i
' loop through issue words and see if it meets tolerance
' if it does, add to the Word Issue cell to the right
For k = 0 To UBound(theIssues)
If (theIssues(k).Count >= countTolerance) Then
If (sIssues = vbNullString) Then
sIssues = theIssues(k).Issue
Else
sIssues = sIssues & ", " & theIssues(k).Issue
End If
End If
Next k
r.Offset(0, 1).Value = sIssues
End Sub