I use the following VBA code to insert the column number from Cell C1 into Cell B1:
Sub AdressColumn()
Sheet1.Range("B1").Value = Sheet1.Range("C1").Column
End Sub
In this case the result on my spreadsheet looks like this:
A B C
1 3
2
3
All this works fine so far.
However, instead of inserting the 3 I would prefer to insert the letter of the column. In this case the letter C should be inserted into Cell B1.
I also tried to go with the formula here but I could not make it work since in my case I do not use a given number. Instead I refer to a Column with the .Column function.
What do I have to change in my formula to make it work?
Split the $ out of an absolute cell address.
Sub AdressColumn()
Sheet1.Range("B1").Value = split(Sheet1.Range("C1").address, "$")(1)
End Sub
... or split the colon out of the relative full column address.
Sub AdressColumn()
Sheet1.Range("B2").Value = Split(Sheet1.Range("C1").EntireColumn.Address(0, 0), ":")(0)
End Sub
user4039065 is very close, but the subscript at the end of the line should be (2). Then, e.g., 677 represents column "ZA" and column 16384 represents "XFD" by the function below:
Const MAX_COL_NUMBER = 16384
...
Function columnNumberToColumnString(col As Integer) As String
If col > MAX_COL_NUMBER Or col < 1 Then
columnNumberToColumnString = "ERROR": Exit Function
Else
columnNumberToColumnString = Split(Columns(col).Address, "$")(2)
End If
' delete code block below after seeing how Split works
msg = "Split <" & Columns(col).Address & ">"
For i = 0 To UBound(Split(Columns(col).Address, "$"))
msg = msg + Chr(13) & Chr(10) & "Substring " & i & _
" is <" & Split(Columns(col).Address, "$")(i) & ">"
Next
MsgBox msg
End Function
In fact, if I use (1) in place of my (2), for column 26 I get Z:, not just Z, as explained below.
The Split function, when used with a valid Excel column address, returns an array of length 3, showing in stages how the final result is arrived at.
For 256, for example, the results displayed by the msg code block are:
Address of column number 256 is <$IV:$IV>
Substring 0 is <> (since first $ is first character, strip it and all after)
Substring 1 is <IV:> (since second $ is after the :, strip it and all after)
Substring 2 is <IV> (since : above is a usual delimiter, strip it)
Split "Returns a zero-based, one-dimensional array containing ... 'all substrings' " (if the limit (third) argument is omitted) of the given expression (first argument).
Related
I have a chart with a text-column with numerous entries per cell.
Entries are separated with “;”.
Entries have the format “xy 00/00” (e.g. “AB 03/18”).
I need Excel to find and give in the next column a specific entry I predefine per row (above the column, example below).
Only the first two and last two characters are defined, the characters in the middle can be whatever (e.g. “AB ??/18”).
A cell can have more than one entry with the definition of “AB ??/18” (e.g. “AB 03/18” & “AB 08/18” etc.).
I need to know, if there are more than 1 of this predefined entries.
If I change the search box to “ZZ ??/12”, it should overwrite the previous defined search and give me back only the ZZ… ones.
For example:
Screenshot Chart
I tried a formula, but it gives me the first AB…, not the rest.
If it is only possible to give back the amount of the searched text in the cell above, that would also be ok.
Your screenshot doesn't seem entirely consistent with your objective, i.e.
the pattern AB ##/18 can be found 3 times in the string
blabla WF 12/23; AB 08/18; AB 09/18; AB 08/18
but your count column registers only 1 result (for AB 08/18)- there is also a match in the 1st row (for AB 12/18), but there you have a count of 0...
The code below assumes that the 4 data cells from your screenshot are in the range A3:A6 and that they are not part of a table
Sub txtMatching()
Dim results As String, cell As Range, incidence As Integer, pattern As String, pos As Integer, temp As String
pattern = "AB ##/18"
For Each cell In Range("A3:A6")
pos = 1
If cell.Value Like "*" & pattern & "*" Then
Do
pos = InStr(pos, cell.Value2, Mid(pattern, 1, InStr(1, pattern, "#") - 1))
If pos = 0 Then Exit Do
temp = Mid(cell.Value2, pos, Len(pattern))
If temp Like pattern Then
results = results & temp & "; "
incidence = incidence + 1
End If
pos = pos + Len(pattern)
Loop While pos < Len(cell.Value2)
cell.Offset(0, 1).Resize(1, 2).Value2 = Array(Mid(results, 1, Len(results) - 2), incidence)
results = vbNullString
incidence = 0
Else
cell.Offset(0, 2).Value2 = 0
End If
Next cell
End Sub
My question is basically the opposite of THIS ONE (which had a database-based solution I can't use here).
I use SAP, which sorts characters this way:
0-9, A-Z, _
but I'm downloading data into Excel and manipulating ranges dependent on correct SAP character set sort order.
How can I force Excel to sort the same way as SAP, with underscore coming last.
After attempting a Custom Sort List of single characters in Excel's Sort feature, Excel still/always sorts like this:
_, 0-9, A-Z
Is there any way to get Excel to sort like SAP? I'm capable of doing Excel macros, if needed.
Alternatively, if anyone knows how to get native SAP tables to sort like Excel in the SAP interface, that would take care of this problem, as well.
The principle of the following solution is to insert a new column in which the cells have a formula which calculates a "sortable code" of each cell of the column that you want to sort.
If you sort this new column, the rows will be sorted in the ASCII order (0-9, A-Z, _).
It should be able to handle any number of rows. On my laptop, the calculation of cells takes 1 minute for 130.000 rows. There are two VBA functions, one for ASCII and one for EBCDIC. It's very easy to define other character sets.
Steps:
Create a module in your Excel workbook and place the code below.
Close the VB editor otherwise it will run slowly.
In the worksheet that you want to sort, insert one column for each column you want to sort, for instance let's say the sort is to be done for column A, create a new column B, in the cell B1 insert the formula =SortableCodeASCII(A1) and do the same for all the cells of column B (up to the last row of column A).
Make sure that the calculation of formulas is over (it takes 1 minute for 130.000 rows on my laptop), otherwise if you sort, the order will be incorrect because formulas are not yet calculated. You see the progress indicator (percentage) on the status bar at the bottom of the Excel window. If you don't see it, press Ctrl+Alt+F9.
Sort on column B. The values in column A should be sorted according to the ASCII order (0-9, A-Z, _)
Good luck!
Option Compare Text 'to make true "a" = "A", "_" < "0", etc.
Option Base 0 'to start arrays at index 0 (LBound(array) = 0)
Dim SortableCharactersASCII() As String
Dim SortableCharactersEBCDIC() As String
Dim SortableCharactersTEST() As String
Sub ResetSortableCode()
'Run this subroutine if you change anything in the code of this module
'to regenerate the arrays SortableCharacters*
Erase SortableCharactersASCII
Erase SortableCharactersEBCDIC
Erase SortableCharactersTEST
Call SortableCodeASCII("")
Call SortableCodeEBCDIC("")
Call SortableCodeTEST("")
End Sub
Function SortableCodeASCII(text As String)
If (Not Not SortableCharactersASCII) = 0 Then
SortableCharactersASCII = getSortableCharacters( _
orderedCharacters:=" !""#$%&'()*+,-./0123456789:;<=>?#ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}" & ChrW(126) & ChrW(127))
End If
SortableCodeASCII = getSortableCode(text, SortableCharactersASCII)
End Function
Function SortableCodeEBCDIC(text As String)
If (Not Not SortableCharactersEBCDIC) = 0 Then
SortableCharactersEBCDIC = getSortableCharacters( _
orderedCharacters:=" ¢.<(+|&!$*);-/¦,%_>?`:##'=""abcdefghi±jklmnopqr~stuvwxyz^[]{ABCDEFGHI}JKLMNOPQR\STUVWXYZ0123456789")
End If
SortableCodeEBCDIC = getSortableCode(text, SortableCharactersEBCDIC)
End Function
Function SortableCodeTEST(text As String)
If (Not Not SortableCharactersTEST) = 0 Then
SortableCharactersTEST = getSortableCharacters( _
orderedCharacters:="ABCDEF 0123456789_")
End If
SortableCodeTEST = getSortableCode(text, SortableCharactersTEST)
End Function
Function getSortableCharacters(orderedCharacters As String) As String()
'Each character X is assigned another character Y so that sort by character Y will
'sort character X in the desired order.
maxAscW = 0
For i = 1 To Len(orderedCharacters)
If AscW(Mid(orderedCharacters, i, 1)) > maxAscW Then
maxAscW = AscW(Mid(orderedCharacters, i, 1))
End If
Next
Dim aTemp() As String
ReDim aTemp(maxAscW)
j = 0
For i = 1 To Len(orderedCharacters)
'Was a character with same "sort weight" previously processed ("a" = "A")
For i2 = 1 To i - 1
If AscW(Mid(orderedCharacters, i, 1)) <> AscW(Mid(orderedCharacters, i2, 1)) _
And Mid(orderedCharacters, i, 1) = Mid(orderedCharacters, i2, 1) Then
'If two distinct characters are equal when case is ignored (e.g. "a" and "A")
'(this is possible only because directive "Option Compare Text" is defined at top of module)
'then only one should be used (either "a" or "A" but not both), so that the Excel sorting
'does not vary depending on sorting option "Ignore case".
Exit For
End If
Next
If i2 = i Then
'NO
aTemp(AscW(Mid(orderedCharacters, i, 1))) = Format(j, "000")
j = j + 1
Else
'YES "a" has same weight as "A"
aTemp(AscW(Mid(orderedCharacters, i, 1))) = aTemp(AscW(Mid(orderedCharacters, i2, 1)))
End If
Next
'Last character is for any character of input text which is not in orderedCharacters
aTemp(maxAscW) = Format(j, "000")
getSortableCharacters = aTemp
End Function
Function getOrderedCharactersCurrentLocale(numOfChars As Integer) As String
'Build a string of characters, ordered according to the LOCALE order.
' (NB: to order by LOCALE, the directive "Option Compare Text" must be at the beginning of the module)
'Before sorting, the placed characters are: ChrW(0), ChrW(1), ..., ChrW(numOfChars-1), ChrW(numOfChars).
'Note that some characters are not used: for those characters which have the same sort weight
' like "a" and "A", only the first one is kept.
'For debug, you may define constdebug=48 so that to use "printable" characters in sOrder:
' ChrW(48) ("0"), ChrW(49) ("1"), ..., ChrW(numOfChars+47), ChrW(numOfChars+48).
sOrder = ""
constdebug = 0 'Use 48 to help debugging (ChrW(48) = "0")
i = 34
Do Until Len(sOrder) = numOfChars
Select Case constdebug + i
Case 0, 7, 14, 15: i = i + 1
End Select
sCharacter = ChrW(constdebug + i)
'Search order of character in current locale
iOrder = 0
For j = 1 To Len(sOrder)
If AscW(sCharacter) <> AscW(Mid(sOrder, j, 1)) And sCharacter = Mid(sOrder, j, 1) Then
'If two distinct characters are equal when case is ignored (e.g. "a" and "A")
'("a" = "A" can be true only because directive "Option Compare Text" is defined at top of module)
'then only one should be used (either "a" or "A" but not both), so that the Excel sorting
'does not vary depending on sorting option "Ignore case".
iOrder = -1
Exit For
ElseIf Mid(sOrder, j, 1) <= sCharacter Then
'Compare characters based on the LOCALE order, that's possible because
'the directive "Option Compare Text" has been defined.
iOrder = j
End If
Next
If iOrder = 0 Then
sOrder = ChrW(constdebug + i) & sOrder
ElseIf iOrder = Len(sOrder) Then
sOrder = sOrder & ChrW(constdebug + i)
ElseIf iOrder >= 1 Then
sOrder = Left(sOrder, iOrder) & ChrW(constdebug + i) & Mid(sOrder, iOrder + 1)
End If
i = i + 1
Loop
'Last character is for any character of input text which is not in orderedCharacters
sOrder = sOrder & ChrW(constdebug + numOfChars)
getOrderedCharactersCurrentLocale = sOrder
End Function
Function getSortableCode(text As String, SortableCharacters() As String) As String
'Used to calculate a sortable text such a way it fits a given order of characters.
'Example: instead of order _, 0-9, Aa-Zz you may want 0-9, Aa-Zz, _
'Will work only if Option Compare Text is defined at the beginning of the module.
getSortableCode = ""
For i = 1 To Len(text)
If AscW(Mid(text, i, 1)) < UBound(SortableCharacters) Then
If SortableCharacters(AscW(Mid(text, i, 1))) <> "" Then
getSortableCode = getSortableCode & SortableCharacters(AscW(Mid(text, i, 1)))
Else
'Character has not an order sequence defined -> last in order
getSortableCode = getSortableCode & SortableCharacters(UBound(SortableCharacters))
End If
Else
'Character has not an order sequence defined -> last in order
getSortableCode = getSortableCode & SortableCharacters(UBound(SortableCharacters))
End If
Next
'For two texts "a1" and "A1" having the same sortable code, appending the original text allows using the sort option "Ignore Case"/"Respecter la casse"
getSortableCode = getSortableCode & " " & text
End Function
EDIT: this solution is based on the automatic calculation of a custom order list, but it doesn't work if there are too many distinct values. In my case it worked with a custom order list of maybe a total of 35.000 characters, but it failed for the big list of the original poster.
The following code sorts the requested column(s) by ASCII value, which has this kind of order:
0-9, A-Z, _, a-z
I guess the lower case being separated from the upper case is not an issue as SAP defines values mostly in upper case. If needed, the code can be easily adapted to obtain the custom order 0-9, Aa-Zz, _ (by using UCase and worksheet.Sort.MatchCase = False).
This order is different from the built-in Excel sort order which is based on the locale. For instance, in English, it would be:
_, 0-9, Aa-Zz
The principle is to use a "custom order list" whose values are taken from the Excel column, made unique, and sorted with a QuickSort3 algorithm (subroutine MedianThreeQuickSort1 provided by Ellis Dee at http://www.vbforums.com/showthread.php?473677-VB6-Sorting-algorithms-(sort-array-sorting-arrays)).
Performance notes about the Excel sorting via custom list (I'm not talking about QuickSort3):
The more the distinct values in the custom order list, the lower the performance. 4,000 rows having 20 distinct values are sorted immediately, but 4,000 rows having 4,000 distinct values takes 8 seconds to sort!
For the same number of distinct values, the performance does not change a lot if there are many rows to sort. 300,000 rows having 6 distinct values takes 3 seconds to sort.
Sub SortByAsciiValue()
With ActiveSheet.Sort
.SortFields.Clear
.SetRange Range("A:A").CurrentRegion
.SortFields.Add Key:=Columns("A"), Order:=xlAscending, _
CustomOrder:=DistinctValuesInAsciiOrder(iRange:=Columns("A"), Header:=True)
.Header = xlYes
.Apply
End With
End Sub
Function DistinctValuesInAsciiOrder(iRange As Range, Header As Boolean) As String
Dim oCell As Range
Dim oColl As New Collection
On Error Resume Next
For Each oCell In iRange.Cells
Err.Clear
If Header = True And oCell.Row = iRange.Row Then
ElseIf oCell.Row > iRange.Worksheet.UsedRange.Rows.Count Then
Exit For
Else
dummy = oColl.Item(oCell.Text)
If Err.Number <> 0 Then
oColl.Add oCell.Text, oCell.Text
totalLength = totalLength + Len(oCell.Text) + 1
End If
End If
Next
On Error GoTo 0
If oColl.Count = 0 Then
Exit Function
End If
Dim values() As String
ReDim values(1)
ReDim values(oColl.Count - 1 + LBound(values))
For i = 1 To oColl.Count
values(i - 1 + LBound(values)) = oColl(i)
Next
Call MedianThreeQuickSort1(values)
' String concatenation is complex just for better performance (allocate space once)
DistinctValuesInAsciiOrder = Space(totalLength - 1)
Mid(DistinctValuesInAsciiOrder, 1, Len(values(LBound(values)))) = values(LBound(values))
off = 1 + Len(values(LBound(values)))
For i = LBound(values) + 1 To UBound(values)
Mid(DistinctValuesInAsciiOrder, off, 1 + Len(values(i))) = "," & values(i)
off = off + 1 + Len(values(i))
Next
End Function
I have a report that includes a bunch of text in one cell. The first part of the text is a product# but the length varies. The product number is separated from the other information by a space.
I'm looking to write a macro that will replace just the first space with a delimiting character. I usually use "~". This will then allow me to script a text-to-columns command that will isolate the product number in one column.
You can do this with a formula:
=LEFT(A1, FIND(" ", A1, 1)-1) & "~" & RIGHT(A1,LEN(A1) - FIND(" ", A1, 1))
Copy that down. Copy/PasteSpecial Values. Then text-to-column that result
With VBA, the following approach is possible:
Locate the first empty string position and write it to a variable
Take the left part of the string to the position and append the replacement string
Take the right part of the string from the position to the end and append the rest
This is the function:
Public Function ReplaceFirstSpace(myInput As String, _
Optional replacement As String = "~") As String
Dim position As Long
position = InStr(1, myInput, " ")
If position = 0 Then
ReplaceFirstSpace = myInput
Else
ReplaceFirstSpace = Left(myInput, position - 1) & _
replacement & Right(myInput, Len(myInput) - position)
End If
End Function
And some tests:
Sub TestMe()
Debug.Print ReplaceFirstSpace("my name is")
Debug.Print ReplaceFirstSpace("slim shaddy")
Debug.Print ReplaceFirstSpace("tikitiki")
Debug.Print ReplaceFirstSpace(" taram")
Debug.Print ReplaceFirstSpace("tam ")
Debug.Print ReplaceFirstSpace("")
End Sub
Use REPLACE:
=REPLACE(A1,FIND(" ",A1),1,"~")
I have a longstanding formatting frustration. I often do this manually but doing it manually takes forever, and there has to be a way to do this with either a VBA macro, conditional formatting or a clever number format.
Below is my desired result. It has the following properties:
The largest number in the column (in this case the last number in the column, $103,420) is centered within the cell.
The largest number in the cell is not, however, center aligned, it is right indented until the value is centered.
All other numbers in the column are also right indented an equal amount. This is desirable because it lines up the ones place, tens place etc. in each number.
Negative numbers are denoted surrounded by parentheses.
The dollar sign is adjacent to the leftmost number.
Commas are included properly for numbers greater than 999.
This result was achieved by:
Applying the following number format:$#,##0_);($#,##0)_);$0_);#_)
Manually adjusting the right indent of the cell on the largest number to determine when it is roughly centered. If more space must be on one side or the other, the larger space is left on the left side of the number.
I attempted to apply a number format similar to the one used in response to this question.
Specifically my attempt at using this was to center align all cells using the following number format: $?,??0;($?,??0);
That produces the following close but not quite result below.
Thoughts on how I can address this? I'm imagining a macro that identifies the largest number in the selection, gets the number of digits in that number, the font size, the width of the column, does some computation yielding the desired right indent and then applies the right indent. I'm just not sure how to do that kind of computation.
'Select your data range, and run formatCells_Accounting(). The number formatting in the selected cells will widen to the cell with the longest value. Note, the macro does not work on values greater than 10^14 (not sure why.)
Sub formatCells_Accounting()
Dim rg As Range
Set rg = Selection
maxVal = Application.WorksheetFunction.Max(rg)
minVal = Application.WorksheetFunction.Min(rg)
If Abs(minVal) > maxVal Then
longest_ = minVal
Else
longest_ = maxVal
End If
lenLongest = Len(CStr(Round(longest_, 0)))
rg.NumberFormat = "_($" & addCommasToFormat(lenLongest) & "_);" & _
"_(($" & addCommasToFormat(lenLongest) & ");" & _
"_($" & addCommasToFormat(lenLongest - 1) & "0_);" & _
"_(#_)"
End Sub
Function addCommasToFormat(ByVal lenLongest) As String
str_ = String(lenLongest, "?")
new_str_ = ""
For i = 1 To Len(str_)
If i Mod 3 = 1 And i <> 1 Then
new_str_ = new_str_ & ",?"
Else
new_str_ = new_str_ & "?"
End If
Next
addCommasToFormat = StrReverse(new_str_)
End Function
Chris - your answer doesn't do what I was hoping for (your answer leaves space between the dollar sign and the "last" digit for numbers shorter than the longest number in the set)
However, your code was a helpful starting point for this solution I've come up with. The result is shown in the image below along with the inherent downside to this solution - running a formula on the numbers in the column after they've been formatted in this way results in a weird number format.
The only solution I can come up with that doesn't have the problem this solution does is, one that relies on estimating an indent, and applying it. That solution only works so long as the column width is not adjusted going forwards. If it is adjusted the macro would have to be re-run. Additionally, because the indent can only be increased by an increment of 1 (and nothing less), a macro that applied an indent would typically result in the largest number in the column not being exactly centered. Not a huge deal but my current solution doesn't have either of these problems and in my use case, these formats are being applied as the last step in the process of formatting a spreadsheet so additional calculations aren't likely to happen and if they do, the macro can simply be re-run as needed.
'Select your data range, and run formatCells_Accounting(). The number formatting in the selected cells will widen to the cell with the longest value. Note, the macro does not work on values greater than 10^14 (not sure why.)
Sub formatCells_Accounting()
Dim rg, thisColRange, rCell As Range
Dim maxVal, minVal, valueLen, longest_, lenLongest As Long
Set rg = Selection
'Center aligns all selected cells
rg.HorizontalAlignment = xlCenter
'Loops through each column in the selected range so that each column can have it's own max value
For Each thisColRange In rg.Columns
maxVal = Application.WorksheetFunction.Max(thisColRange)
minVal = Application.WorksheetFunction.Min(thisColRange)
'The longest number in the range may be the most negative
'This if section accounts for this scenario
If Abs(minVal) > maxVal Then
longest_ = minVal
Else
longest_ = maxVal
End If
'Gets the length of the longest value rounded to the ones place (aka length not including decimals)
lenLongest = Len(CStr(Round(Abs(longest_), 0)))
'Creates a number format for every cell
For Each rCell In thisColRange.Cells
'Gets the length of the value in the current cell
valueLen = Len(CStr(Round(Abs(rCell.Value), 0)))
rCell.NumberFormat = "_(" & addCommasDollarsToFormat(lenLongest, valueLen, rCell.Value) & "_);" & _
"_(" & addCommasDollarsToFormat(lenLongest, valueLen, rCell.Value) & ")_);" & _
"_(" & Left(addCommasDollarsToFormat(lenLongest, 1, rCell.Value), Len(addCommasDollarsToFormat(lenLongest, 1, rCell.Value)) - 1) & "0_);" & _
"_(#_)"
Next
Next
End Sub
Function addCommasDollarsToFormat(ByVal lenLongest, ByVal valueLen, ByVal cellVal) As String
Dim new_str_ As String
Dim i, j As Long
'Initializes empty strings
new_str_ = ""
nearlyFinishedString = ""
'Adds ? and , through the length of the value currently being formatted
For i = 1 To valueLen
If i Mod 3 = 1 And i <> 1 Then
new_str_ = new_str_ & ",?"
Else
new_str_ = new_str_ & "?"
End If
Next
If cellVal < 0 Then
new_str_ = new_str_ & "$("
Else
new_str_ = new_str_ & "$"
End If
For j = i To lenLongest
If j Mod 3 = 1 Then
new_str_ = new_str_ & ",?"
Else
new_str_ = new_str_ & "?"
End If
Next
addCommasDollarsToFormat = StrReverse(new_str_)
End Function
Solution visualized with the downside of the solution shown below it.
I have a list of cells with values like the below:
a,a,b,c,d
f,g,h,h,h,j
a,b,b
f,f,f,y,y,u,u
I want a formula that will give me the below (unique list of above). I should be able to write it for one row and copy it down.
a,b,c,d
f,g,h,j
a,b
f,y,u
There is no way to do this with a formula that will return comma-separated unique results into one cell, using only the built-in worksheet functions.
But, it is very simple to achieve the same thing with a User Defined Function (UDF).
Just place this small routine in a standard code module:
Public Function UniqueList(s)
Dim i&, k$, v
v = Split(s, ",")
For i = 0 To UBound(v)
If InStr(k, v(i)) = 0 Then k = k & "," & v(i)
Next
UniqueList = Mid$(k, 2)
End Function
If your source string is in cell A1 then in cell B1 enter this formula:
=UniqueList(A1)
That's it. Now copy the formula downward as far as needed.
Considering the repeated letters are in order, as in your sample, this should do the trick:
Function UniqueLetters(ByVal cell As Range) As String
letters = Split(cell.Value, ",")
For Each letter In letters
If letter <> current_letter Then
current_letter = letter
unique_letters = unique_letters + letter + ","
End If
Next
UniqueLetters = Left(unique_letters, Len(unique_letters) - 1)
End Function