In Excel 2010, I have a column of names in the format: "Last, First MI" (<--edit, no comma after first name)
I'd like to have a macro that removes the MI from the string. Here's what I've tried so far:
Sub FirstNameFirst()
Dim theName, firstspot, secondspot, finalName As String
Dim oCell As Range
For Each oCell In Selection
firstspot = InStr(theName, " ")
secondspot = InStr(firstspot + 1, theName, " ")
oCell = Mid(theName, 1, secondspot - 1)
Next oCell
End Sub
I've learned that you can't do string manipulation like that on a Range datatype. Any suggestions?
Another way would be to use InStrRev:
Sub test()
Dim oCell As Range, i as Integer
For Each oCell In Selection
i = InStrRev(oCell, " ")
If i <> 0 Then
oCell = Left(oCell, i - 1)
End If
Next oCell
End Sub
You can use Split to separate the names parts into an array and then just index it to get the result you need:
Sub FirstNameFirst()
Dim cl As Range, arr As Variant
For Each cl In Selection
arr = VBA.Split(cl, ",")
cl = arr(0) & "," & arr(1)
Next cl
End Sub
Related
The excel cell has a formula of form =SUM(I1:I5). How can we convert it into its explicit form:
=I1+I2+I3+I4+I5
Another approach with .Precedents:
Sub expandSUM()
Range("A1").Formula = "=SUM(I1:I5)" 'the formula must be in the cell
Output = "=SUM("
For Each cl In Range("A1").Precedents
Output = Output & "+" & cl.Address(False, False)
Next
Debug.Print Replace(Output, "(+", "(") & ")"
End Sub
This feels like a post on Code Golf. Here's my version of a function that can do this.
Function ExplicitSum(ByVal expression As String) As String
Dim strStart As Long, strEnd As Long
strStart = InStr(1, UCase(expression), "SUM(") + 4
If strStart = 0 Then
'SUM not found
ExplicitSum = expression
Exit Function
End If
strEnd = InStr(strStart + 1, expression, ")")
If strEnd = 0 Then
'closing bracket not found
ExplicitSum = expression
Exit Function
End If
Dim LeftText As String, RightText As String, AddressText As String
LeftText = Replace(Left(expression, strStart - 1), "sum(", "(", Compare:=vbTextCompare)
AddressText = Mid(expression, strStart, strEnd - strStart)
RightText = Right(expression, Len(expression) - strEnd + 1)
If InStr(1, UCase(RightText), "SUM(") <> 0 Then
'Recursion will handle multiple sums in the same formula
RightText = ExplicitSum(RightText)
End If
Dim SumRange As Range
On Error Resume Next
Set SumRange = Range(AddressText)
On Error GoTo 0
If SumRange Is Nothing Then
'Invalid AddressText - Named Ranges or Indirect reference
ExplicitSum = LeftText & AddressText & RightText
Exit Function
End If
Dim Addresses() As String
ReDim Addresses(1 To SumRange.Cells.Count)
Dim cell As Range, i As Long: i = 1
For Each cell In SumRange
Addresses(i) = cell.Address(False, False)
i = i + 1
Next cell
ExplicitSum = LeftText & Join(Addresses, "+") & RightText
End Function
Examples of how to use the function:
Sub test()
MsgBox ExplicitSum("=5+sum(A1:D1)/20")
'Displays "=5+(A1+B1+C1+D1)/20"
End Sub
Sub ExampleUsage()
'Put the formula back into the cell after transforming
Range("E1").Formula = ExplicitSum(Range("E1").Formula)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Run on every cell with SUM in its formula
If LCase(Target.Cells(1,1).Formula) Like "*sum(*" Then Target.Cells(1,1).Formula = ExplicitSum(Target.Cells(1,1).Formula)
End Sub
Will work with complex formulas.
Will work with multiple SUMS in the same formula.
Will work with Named Ranges inside the Sum.
I wrote a function to do this via string manipulations.
I tested with
Before =SUM(C2:C4,E2:G2,D7:E8)
After =$C$2+$C$3+$C$4+$E$2+$F$2+$G$2+$D$7+$E$7+$D$8+$E$8
Usage, call ExpandSum() with the target cell as an argument
Public Sub ExpandSum(ByVal r_target As Range)
Dim f As String
f = Mid(r_target.Formula, 2)
' Is it a SUM function
If Left(f, 3) = "SUM" Then
' Take the arguments of SUM
f = Mid(f, 5, Len(f) - 5)
' make an array of string with each
' arument
Dim parts() As String
parts = Split(f, ",")
Dim i As Long, n As Long
n = UBound(parts) + 1
Dim rng As Range, cl As Range
Dim col As New Collection
For i = 1 To n
' for each argument find the range of cells
Set rng = Range(parts(i - 1))
For Each cl In rng
' Add each cell in range into a list
col.Add cl.Address
Next
Next i
' Transfer list to array
ReDim parts(0 To col.Count - 1)
For i = 1 To col.Count
parts(i - 1) = col(i)
Next i
' Combine parts into one expression
' ["A1","A2","A3"] => "A1+A2+A3"
f = Join(parts, "+")
r_target.Formula = "=" & f
End If
End Sub
Example of calling with the current selection
Public Sub ThisExpandSum()
Call ExpandSum(Selection)
End Sub
Caveats I don't know how it will behave if the sum contains literal values, or cells from different sheets. That can be functionality to be added later.
Use the next function, please:
Function SUMbyItems(strFormula As String) As String
If strFormula = "" Then Exit Function
Dim rng As Range, Ar As Range, c As Range, strF As String
Set rng = Range(left(Split(strFormula, "(")(1), Len(Split(strFormula, "(")(1)) - 1))
For Each Ar In rng.Areas
For Each c In Ar.cells
strF = strF & c.Address(0, 0) & "+"
Next c
Next
strF = left(strF, Len(strF) - 1)
SUMbyItems = "=SUM(" & strF & ")"
End Function
It can be used, selecting a cell having a SUM formula containing a range and run the next Sub:
Sub testSumByItems()
Debug.Print SUMbyItems(ActiveCell.Formula)
End Sub
If it returns what you want and you need changing the range formula with its expanded version, you can use (in the above testing Sub):
ActiveCell.Formula = SUMbyItems(ActiveCell.Formula)
I have a column of Excel cells that follow this format (the random strings are not in a fixed order). Strings that don't start with a certain string need to be removed.
randomstringA text_that_needs_to_be_kept1
text_that_needs_to_be_removed1
randomstringB text_that_needs_to_be_kept2
randomstringA text_that_needs_to_be_kept3
text_that_needs_to_be_removed2
I want the cell's output to be this (linebreak must be kept):
text_that_needs_to_be_kept1
text_that_needs_to_be_kept2
text_that_needs_to_be_kept3
And not this (linebreak got removed):
text_that_needs_to_be_kept1
text_that_needs_to_be_kept2
text_that_needs_to_be_kept3
The following code will go down column A starting in row 1 and remove any line that doesn't start with a value from the array arrToKeep, keeping the linebreaks.
Option Explicit
Sub RemoveStrings()
Dim rngData As Range
Dim arrData As Variant
Dim arrLines As Variant
Dim arrToKeep As Variant
Dim idx1 As Long
Dim idx2 As Long
Dim idxRow As Long
Dim boolKeep As Boolean
arrToKeep = Array("randomstringA", "randomstringB")
Set rngData = Range("A1", Range("A" & Rows.Count).End(xlUp))
arrData = rngData.Value
For idxRow = LBound(arrData, 1) To UBound(arrData, 1)
arrLines = Split(arrData(idxRow, 1), vbLf)
For idx1 = LBound(arrLines) To UBound(arrLines)
boolKeep = False
For idx2 = LBound(arrToKeep) To UBound(arrToKeep)
If arrLines(idx1) Like arrToKeep(idx2) & "*" Then
boolKeep = True
Exit For
End If
Next idx2
If Not boolKeep Then
arrLines(idx1) = ""
End If
Next idx1
arrData(idxRow, 1) = Join(arrLines, vbLf)
Next idxRow
rngData.Value = arrData
End Sub
In B1 place this formula =IF(LEFT(A1;1)="r";MID(A1;FIND(" ";A1;1)+1;500);"") and copy+paste to the other cells in column B.
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 requesting a parameter from the user to specify columns (in Excel) to select, but am having some issues with converting the value to a string that I can use in VBA for reference.
I'm trying to avoid having the user enter A:A,E:E,D:D,S:S and instead just enter A,E,D,S in a cell. I'm sure the answer is right there but at the moment it's escaping me. Any suggestions?
Like I said,
Split on the , and iterate through the resultant array and build the range:
Sub fooooo()
Dim str As String
Dim rng As Range
Dim strArr() As String
str = "A,E,D,S" 'you can change this to the cell reference you want.
strArr = Split(str, ",")
With Worksheets("Sheet1") ' change to your sheet
Set rng = .Range(strArr(0) & ":" & strArr(0))
For i = 1 To UBound(strArr)
Set rng = Union(rng, .Range(strArr(i) & ":" & strArr(i)))
Next i
End With
Debug.Print rng.Address
End Sub
You can always turn this into a Function that returns a range:
Function fooooo(str As String, ws As Worksheet) As Range
Dim rng As Range
Dim strArr() As String
strArr = Split(str, ",")
With ws ' change to your sheet
Set rng = .Range(strArr(0) & ":" & strArr(0))
For i = 1 To UBound(strArr)
Set rng = Union(rng, .Range(strArr(i) & ":" & strArr(i)))
Next i
End With
Set fooooo = rng
End Function
Then you would call it like this from any sub you need:
Sub foofind()
Dim rng As Range
Dim str As String
str = "A,E,D,S"
Set rng = fooooo(str, Worksheets("Sheet1"))
Debug.Print rng.Address
I am putting together a basic macro to format a column to include reference letters. For example, one column has 1,2,3 and there is a cell where the user can input some letters and click a button. ABC for example. This when working shall format 1,2,3 to now be ABC1, ABC2, ABC3 etc.
I have achieved this somewhat but it only works for the letter A. See below:
Sub Macro4()
Range("A3:A60").Select
Selection.NumberFormat = Range("k11").Text & "0" & "0" & "0"
End Sub
Here's my attempt. I'm quite certain there is a better way:
Option Explicit
Sub TestMacro()
Dim MyRange As Range
Dim MyReference As Range
Dim MyArray() As Variant
Dim Counter As Long
Dim wf As WorksheetFunction
Dim Cell As Range
Dim val As Integer
Application.ScreenUpdating = False
Set wf = Application.WorksheetFunction
Set MyRange = Range("A3:A60")
For Each Cell In MyRange
val = Application.Evaluate("=MIN(SEARCH({0,1,2,3,4,5,6,7,8,9}," & Cell.Address & "&" & """0,1,2,3,4,5,6,7,8,9""" & "))")
Cell = CInt(Mid(Cell, val, Len(Cell) - val + 1))
Next Cell
Set MyReference = Range("B3")
MyArray = Application.Transpose(MyRange)
For Counter = LBound(MyArray) To UBound(MyArray)
MyArray(Counter) = MyReference & CStr(MyArray(Counter))
Next Counter
MyRange = Application.Transpose(MyArray)
Application.ScreenUpdating = True
End Sub