What it does: I have a section of code which finds a substring TL in a cell, and forces the numbers following it to be of length 6 by adding or deleting 0s immediately following "TL-". (ie TL-00072 -> TL-000072, TL-034 -> TL-000034, TL-000000789 -> TL-000789)
What I want it to do: However, sometimes there are multiple TL values in one cell. I need to find if there is a second occurance of TL, and, if yes, delete that second occurance and everything following it.
Example:
Start: Output:
TL-000789 TL-000187 TL-000773 -> TL-000789
TL-000689 TL -000787 -> TL-000689
TL-000982 TL - 980819 -> TL-000982
This is the attempt at code I have been working on (incorrect and not working) using split (maybe trim would work too?) that would find the second occurence of TL and delete everything after it. Full working code below that.
CURRENT ATTEMPT AT CODE
Dim splitValues As Variant
If Str(str, "TL" + 1) 'do not know how to get SECOND occurrence
splitValues = Split(theValue, "TL")
theValue = splitValues(0)
End If
WORKING CODE
[will add new code to beginning] (explanation at top of question)
NOTE: StartSht is the workbook where the values are as well as the code.
All values being altered are in column "C"
'force length of TL/CT to be 6/4 numbers long, eliminate spaces
Dim str As String, ret As String, tmp As String, j As Integer, k As Integer
For k = 2 To StartSht.Range("C2").End(xlDown).Row
ret = ""
str = StartSht.Range("C" & k).Value
'for TL numbers
''''''''''''''new code goes here''''''''''''''''''
If InStr(str, "TL") > 0 Then
For j = 1 To Len(str)
tmp = Mid(str, j, 1)
If IsNumeric(tmp) Then ret = ret + tmp
Next j
'force to 6 numbers if too short; add 0s immediately after "TL-"
For j = Len(ret) + 1 To 6
ret = "0" & ret
Next j
'force to 6 numbers if too long; eliminate 0s immediately after "TL-"
If Len(ret) > 6 Then
Debug.Print Len(ret)
For j = Len(ret) To 7 Step -1
If Mid(ret, 1, 1) = "0" Then
ret = Right(ret, j - 1)
End If
Next j
End If
'eliminate superfluous spaces around "TL-"
ret = "TL-" & ret
StartSht.Range("C" & k).Value = ret
'for CT numbers
ElseIf InStr(str, "CT") > 0 Then
For j = 1 To Len(str)
tmp = Mid(str, j, 1)
If IsNumeric(tmp) Then ret = ret + tmp
Next j
'force to 4 numbers if too short; add 0s immediately after "CT-"
For j = Len(ret) + 1 To 4
ret = "0" & ret
Next j
'force to 4 numbers if too long; eliminate 0s immediately after "CT-"
If Len(ret) > 4 Then
Debug.Print Len(ret)
For j = Len(ret) To 5 Step -1
If Mid(ret, 1, 1) = "0" Then
ret = Right(ret, j - 1)
End If
Next j
End If
'eliminate superfluous spaces around "CT-"
ret = "CT-" & ret
StartSht.Range("C" & k).Value = ret
End If
Next k
It looks like you could just redefine str if you find a second "TL". After the line:
If InStr(str, "TL") > 0 Then
add another IF statement:
If InStr(3, str, "TL") > 0 Then str = Mid(str, 1, Instr(3, str, "TL") - 2)
Then continue with the rest of your code using the new str.
Related
The original code in Box 1 and the code in Box 2 are published on this Q＆A site . But, originally written in Japanese, so I translated to English with minor modifications. Both of them seems to be intended to enumerating the combinations of r elements out of N elements. However, I don't understand the principle behind the Box1's code.
My question
How can the Box1's macro list all the combinations that choose r elements from among N elements? I want to know mathematical principles of Box1's code.
I understand the principle of Box2's code.
Note 1: The logic of the Box2 code is as follows;
Each number below 2^N-1 is written in binary notation.
Consider the bits corresponding to 2^i to be the i-th element.
Consider the i-th element as chosen if it is 1 and not chosen if it is 0.
Thus, any combination of that "selects n "or less" elements" are listed.
Only those with exactly k number of 1's are left.
Simply, Box2's logic is a logic such that only the sets which satisfies the following condition survive;
Condition: "Number of elements whose bit=1" is r.
The code in Box 1 seems to export essentially the same results, but with fewer calculations.
Actually, after much experimentation, export of the Box1's code and Box2's code are essentially same. For example, Table 1 below shows the output for N = 5 and r = 3 . It displays 0 for the elements we don't choose and 1 for the elements we do choose.
But why can the code in Box 1 output the Essentially equivalent results to Box2's code?
Table1.A list of combinations, such that choosing 3 elements out of 5 elements
You can download XLSM file having both Box1's and Box2's macro from here.
Box1.
Sub Cmb()
Dim n, r, m, i, j, c(), o()
n = 5 'Please specify the N
r = 3 'Please specify the r
m = WorksheetFunction.Combin(n, r)
ReDim c(r), o(m, n)
For j = 0 To r: c(j) = j: Next
o(0, 0) = "Decimal"
For j = 1 To n: o(0, j) = "Elements" & j: Next
i = 1
Do While c(0) <= 0
For j = 0 To n: o(i, j) = 0: Next
For j = 1 To r
o(i, 0) = o(i, 0) + 2 ^ (c(j) - 1)
o(i, n + 1 - c(j)) = 1
Next
i = i + 1
nc n, r, c
Loop
Cells(1, 1).Resize(m + 1, n + 1).Value = o
End Sub
Sub nc(n, r, ByRef c())
Dim j, k
For j = r To 0 Step -1
c(j) = c(j) + 1
For k = j + 1 To r: c(k) = c(k - 1) + 1: Next
If c(j) <= n - r + j Then Exit For
Next
End Sub
Box2.
Sub enumeration_of_combinations()
Dim table_()
n = 5
r = 3
Number_of_elements = WorksheetFunction.Combin(n, r)
ReDim table_(1 To Number_of_elements)
cnt = 1
Nmax = (2 ^ n) - 1
For i = 1 To Nmax
Number_of_bits = 0: modulo_ = i
For j = 0 To n
Quotient_ = modulo_ \ 2 ^ (n - j)
modulo_ = modulo_ Mod 2 ^ (n - j)
Number_of_bits = Number_of_bits + Quotient_
Next j
If Number_of_bits = r Then
table_(cnt) = i: cnt = cnt + 1
End If
Next i
For i = 1 To Number_of_elements
modulo_ = table_(i)
For j = 0 To n
Quotient_ = modulo_ \ 2 ^ (n - j)
modulo_ = modulo_ Mod 2 ^ (n - j)
Cells(i + 1, j + 1) = Quotient_
Next j
Cells(i + 1, 1) = table_(i)
Next i
Cells(1, 1) = "Decimal": For j = 1 To n: Cells(1, j + 1) = "element" & j: Next j
End Sub
Reference.
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14208784379 (Written in Japanese)
This is what you should do:
break all those single-line For-Next cycle to make them easily readable by you;
rename all the variables with name made of multiple letters (at least 3 each) that has some sense according to the use the code make of them. To determine it, search for them in the code and interpret it;
if the purpose of one variable is not clear, try with another one;
if you still can't figure the purpose of some of the variables, use the immediate and local window while stopping the code during its execution. With this code you can also run the code once to have the result on sheet and re-run and stop it.
write the appropriate notes.
You should end with something like this:
Sub SubCombinations()
'Declarations.
Dim TotalBits, PositiveBits, CombinationsCount, Counter01, Counter02, ExponentsArray(), ResultArray()
'Setting variables.
TotalBits = 5 'Please specify the N
PositiveBits = 3 'Please specify the r
CombinationsCount = WorksheetFunction.Combin(TotalBits, PositiveBits)
'Reallocating variables.
ReDim ExponentsArray(PositiveBits), ResultArray(CombinationsCount, TotalBits)
'Setting the starting position of the ExponentsArray. This will result in the first line having all the 1 on the right.
For Counter02 = 0 To PositiveBits
ExponentsArray(Counter02) = Counter02
Next
'Setting the headers.
ResultArray(0, 0) = "Decimal"
For Counter02 = 1 To TotalBits
ResultArray(0, Counter02) = "Elements" & Counter02
Next
'Setting variable.
Counter01 = 1
'When ExponentsArray(0) will be greater than 0, we will have covered all possible combinations.
Do While ExponentsArray(0) <= 0
'Set all the bits in the given result row as 0.
For Counter02 = 0 To TotalBits
ResultArray(Counter01, Counter02) = 0
Next
'Covering all the positive bits requested for the row.
For Counter02 = 1 To PositiveBits
'Increasing the decimal result by 2 elevated by the power of the value of attributed to the given bit.
ResultArray(Counter01, 0) = ResultArray(Counter01, 0) + 2 ^ (ExponentsArray(Counter02) - 1)
'Reporting the positive bit in its proper location on the row.
ResultArray(Counter01, TotalBits + 1 - ExponentsArray(Counter02)) = 1
Next
'Setting Counter01 to cover the next row.
Counter01 = Counter01 + 1
'Calling SubExponentsShift
SubExponentsShift TotalBits, PositiveBits, ExponentsArray
Loop
'Reporting the results.
Cells(1, 1).Resize(CombinationsCount + 1, TotalBits + 1).Value = ResultArray
End Sub
Sub SubExponentsShift(TotalBits, PositiveBits, ByRef ExponentsArray())
'Declarations.
Dim Counter01, Counter02
'Covering all the values in the ExponentsArray.
For Counter01 = PositiveBits To 0 Step -1
'Increasing the exponent value. This will make "the given bit shift to the left".
ExponentsArray(Counter01) = ExponentsArray(Counter01) + 1
'If we have "shifted" a bit that was not the first on the right, we have to correct the overshoot of the other bit "shifted" previously.
For Counter02 = Counter01 + 1 To PositiveBits
ExponentsArray(Counter02) = ExponentsArray(Counter02 - 1) + 1
Next
'If we have overshoot while "shifting the position" of the given bit, the For-Next cycle continues.
If ExponentsArray(Counter01) <= TotalBits - PositiveBits + Counter01 Then
Exit For
End If
Next
End Sub
It will then be easier to realize how the code works. The subroutine actually sets the starting conditions and produce each row of the result while the function focuses on "shifting the position" of the bits for each row of the result. Matematically speaking, the code just increase metodically the exponents of given set of powers of 2 whose result are then sum; this goes on until all the unique combinations are covered.
I would like to insert a space between numbers and letters in a column.
Example of the text in the column.
925 LANE AVE SOUTH apt106H
85SW162ND
P O BOX101586
11939 magnolia falls DRIVE
1029BAILLIES ROAD
6870 SR207
14701 nw 77 TH AVENUE
14701NW77THAVENUE
1325NW93CTB103
Po Box272771
2137FERNWOODlane
5702 highway 17/92 CASSELBERRY FL
2254 NW 82 NS AVE
9110SW13TH aveAPT #203
I was thinking of a flag which will toggle if it finds a non-numeric character and will also add a space in the process. This should also work when it finds a numeric character.
Function AddSpace(Str As String) As String
Dim StringLength As Integer
Dim Flag As Integer ' Flag 0 means char, 1 means numeric
StringLength = Len(CellRef)
For i = 1 To StringLength
If IsNumeric(Mid(CellRef, i, 1))
Then Flag = 1
Result = Result & Mid(CellRef, i, 1)
else Flag = 0
endif
Result = Result & Mid(CellRef, i, 1)
Next i
AddSpace = Result
End Function
How about:
Public Function spacer(s As String) As String
Dim i As Long, buf As String, L As Long
L = Len(s)
If L < 2 Then
spacer = s
Exit Function
End If
buf = Left(s, 1)
For i = 2 To L
v1 = Right(buf, 1)
v2 = Mid(s, i, 1)
If (v1 Like "[a-zA-Z]" And v2 Like "[0-9]") Or (v2 Like "[a-zA-Z]" And v1 Like "[0-9]") Then
buf = buf & " "
End If
buf = buf & v2
Next i
spacer = buf
End Function
I've the following Excel data:
A B C
+ ------------ ------------- -----------------
1 | WORD WORD MIX MATCH TEXT RESULT
2 | somewordsome emsomordsowe ...
3 | anotherword somethingelse ...
4 | ... ... ...
I'd like to:
Firstly, get an array, say ArrayOfGroups, by splitting the string in the A2 cell in unique groups of 2 to 12 adjacent chars (note: 2 is the minimum number of chars to form a group; 12 is the total number of the word's chars) i.e. the groups of 2 chars would be so, om, me, ew, wo, or, rd, ds (note: the last so, om and me groups are excluded because they are repeated); the groups of 3 chars would be som, ome, mew, ewo, wor, ord, rds, dso (last som and ome excluded); the groups of 4 chars would be some, omew, mewo, ewor, word, ords, rdso, dsom; ... and so on until the full string somewordsome.
Then, iterate the above-mentioned ArrayOfGroups to check if each of its element is a substring of the B2 cell and return a new array, say ArrayOfMatches, containing all the elements (the characters "group names") that are substrings of B2 and the number of occurrences found in B2.
Finally, output in the C2 cell a sentence built using the ArrayOfMatches data that says something like this:
2 matches for so, 1 match for som and rd
Probably there are other and better approaches to compute the above sentence that is the final result wanted. Maybe I need to use a User Defined Function... but I never made it.
Is there someone that could give help?
May try something like this
Code edited to avoid counting for same substring found multiple times.
Sub test2()
Dim Xstr As String, Ystr As String
Xstr = "somewordsome"
Ystr = "emsomordsowe"
MsgBox Xmatch2(Xstr, Ystr)
End Sub
Function Xmatch2(Xstr As String, Ystr As String) As String
Dim XSubStr As String, YSubStr As String
Dim xLn As Integer, yLn As Integer
Dim XArr As Variant, LnSubStr As Integer
Dim Rslt As String, Cnt As Integer
Dim Xrr() As Variant, Xcnt As Integer, Chk As Boolean
Rslt = "'"
xLn = Len(Xstr)
yLn = Len(Ystr)
For LnSubStr = 2 To xLn 'length of substring
Xcnt = 0
ReDim XArr(1 To 1)
For Y = 1 To xLn
XSubStr = ""
Xcnt = Xcnt + 1
ReDim Preserve XArr(1 To Xcnt)
If Y + LnSubStr - 1 <= xLn Then XSubStr = Mid(Xstr, Y, LnSubStr)
XArr(Xcnt) = XSubStr
Chk = False
For i = 1 To Xcnt - 1
If XArr(i) = XSubStr Then
Chk = True
Exit For
End If
Next
If XSubStr <> "" And Chk = False Then
Cnt = 0
ReDim Preserve XArr(1 To Xcnt)
For Z = 1 To yLn
YSubStr = ""
If Z + LnSubStr - 1 <= yLn Then YSubStr = Mid(Ystr, Z, LnSubStr)
If YSubStr = XSubStr Then Cnt = Cnt + 1
Next
If Cnt > 0 Then Rslt = Rslt & Cnt & " Matches for " & XSubStr & ","
End If
Next
Next
Debug.Print Rslt
Xmatch2 = Rslt
End Function
I'm trying to compare 2 3-digit numbers. This is my current code using nested Ifs
If Mid(Num1, 1, 1) = Mid(Num2, 1, 1) Then
'Check first number against first number
If Mid(Num1, 2, 1) = Mid(Num2, 2, 1) Then
'Check second number against second number
If Mid(Num1, 3, 1) = Mid(Num2, 3, 1) Then
'Check third number against third number
Digits = 3
Else
Digits = 2
End If
And this is just one small part of it. Also, I need to check the order in which they match as well. So whether it's an exact match, all 3 digits match in any order, or if 1 or 2 digits match in any order.
The problem is I have a lot of If statements using this method as I have to compare every combination of digits to check for a 1 digit, 2 digit, 3 digit, etc, match. Is there a better way?
Can be simplified to a function with a simple for loop
Private Function digitMatch(ByVal num1 as String, ByVal num2 as String) As Byte
' num1 and num2 are strings, because of presumption they can start with 0
' (i.e. 042 is valid 3 digit number format, otherwise they can be integers as well)
Dim i As Byte
Dim matches As Byte: matches = 0
For i = 1 To Len(num1)
If InStr(1, num2, Mid(num1, i, 1)) <> 0 Then
matches = matches + 1
End If
Next i
digitMatch = matches
End Function
so eg. digitMatch(023, 053) would return 2
or digitMatch(123, 321) would return 3
In my answer, I return the digits that match, so you can check if there are any and which ones. Also, it works with any number of digits.
Public Function CheckForMatch(ByVal curNum As String, ByVal winNumber As String) As String
Dim i As Long, j As Long
Dim hit As String
hit = vbNullString
For i = 1 To Len(curNum)
j = InStr(1, winNumber, Mid(curNum, i, 1), vbTextCompare)
If j > 0 Then
hit = hit & Mid(curNum, i, 1)
End If
Next i
CheckForMatch = hit
End Function
Public Sub Test()
Dim check As String
check = CheckForMatch("75214", "13672")
If Len(check) > 0 Then
Debug.Print "Numbers " & check & " are a match."
' 721
Else
Debug.Print "No match. Sorry."
End If
End Sub
NOTE: The use of InStr() here was inspired by the answer Rawplus gave before me.
Try this (it will only work correctly if both 'curNum' and 'WinningNumber' are 3 digits long):
'straight match
If curNum = WinningNumber Then
M = 3
s = 3
'matched the first 2 straight
ElseIf InStr(1, WinningNumber, Left(curNum, 2)) > 0 Then
M = 2
s = 2
If InStr(1, WinningNumber, Right(curNum, 1)) > 0 Then M = M + 1
'matched the last 2 straight
ElseIf InStr(2, WinningNumber, Right(curNum, 2)) > 0 Then
M = 2
s = 2
If InStr(1, WinningNumber, Left(curNum, 1)) > 0 Then M = M + 1
'any other scenario
Else
s = 0
For i = 1 To 3
n = Mid(WinningNumber, i, 1)
If InStr(1, curNum, n) > 0 Then
M = M + 1
End If
Next
End If
Debug.Print "Matched digits: " & M
Debug.Print "Straight: " & s
I'm sure there's a better way to do it but this was the easiest way for me to write it up quickly.
I'm a novice with Excel VBA and what I need to do is take a few cells in a column that contain a name and a phone number and cut the phone number out of that cell and paste it in another column, so I'll have one cell with the name and another with the number.
For some reason my program goes into an infinite loop.
I'm pretty sure it's caused by sLen = sLen - 1 & j = j - 1 but I don't know how to solve it.
Sub loop_macro()
Dim myStr As String
Dim i As Integer
For i = 5 To 15
myStr = movePhone(Cells(i, 2), i)
Cells(i, 5) = myStr
Next i
End Sub
Function movePhone(s As String, rowNum As Integer) As String
Dim retval As String // This is the return string to be copied to column 5
Dim j As Integer // Counter for character position.
Dim sLen As Integer
retval = ""
sLen = Len(s)
For j = 1 To sLen
If Mid(s, j, 1) >= "0" And Mid(s, j, 1) <= "9" Then
retval = retval + Mid(s, j, 1)
Cells(rowNum, 2) = Mid(Cells(rowNum, 2), j, 1) // remove digit from cell
sLen = sLen - 1
j = j - 1
ElseIf Mid(s, j, 1) = "-" Then
retval = retval + Mid(s, j, 1)
Cells(rowNum, 2) = Mid(Cells(rowNum, 2), j, 1) // remove "-" char from cell
sLen = sLen - 1
j = j - 1
End If
Next
movePhone = retval
End Function
Instead of messing around so much with manipulating J so you can go left to right go right to left like so:
for j = sLen to 1 step -1
Now you can ommit the line j=j-1 and it will no longer give you this problem.
Always start at the end and work your way to the start when removing things from strings or even data sets, it's much easier than manipulating the variable you are looping on.
In this instance you should consider using Regexp (Regular Expressions) I have not used them before but they will find number strings within strings (and so much more if you want). Search SO for regexp and you will find heaps of code to help you out.