Cell A2 is the data given which has different lines breaks. I separated the data before and after "-" as shown in B2 & C3. Then I sorted the data of C2 from lowest to largest in D2. The desire result is cell E2. I would like to have a user define function to get index B2 by matching D2 from C2. Please note A2 has four values in 4 lines breaks in one cell not in every cell there is a value, please find attached.
The UDF below will do what you want. Call it from the worksheet like =InexMatch(A2). Make sure that the cell you place it in has its WrapText property set to True.
Function InexMatch(Cell As Range) As String
' 003
Dim Arr As Variant
Dim Sp() As String
Dim Tmp As String
Dim Done As Boolean
Dim i As Integer
Arr = Split(Cell.Value, Chr(10))
For i = 0 To UBound(Arr)
Sp = Split(Arr(i), "-")
Arr(i) = Sp(1) & "-" & Sp(0)
Next i
Do
Done = True
For i = 0 To UBound(Arr) - 1
If Val(Arr(i + 1)) < Val(Arr(i)) Then
Tmp = Arr(i)
Arr(i) = Arr(i + 1)
Arr(i + 1) = Tmp
Done = False
End If
Next i
Loop While Not Done
On Error Resume Next
ReDim Sp(UBound(Arr))
For i = 0 To UBound(Arr)
Sp(i) = Split(Arr(i), "-")(1)
Next i
InexMatch = Join(Sp, Chr(10))
End Function
The function will return a null string if the referenced cell is blank. It can deal with cells that have fewer than 4 lines. It will fail if the CR isn't ANSII Chr(10) or the dash isn't a ANSII Chr(45) - a minus sign. It has no provision for incomplete lines within cells, meaning lines which don't have characters on both sides of a dash.
In order to restore the original format in the sorted string please delete all the lines below the end of the Do Loop in the code above, starting with On Error Resume Next, and replace them with the following.
For i = 0 To UBound(Arr)
Sp = Split(Arr(i), "-")
Arr(i) = Sp(1) & "-" & Sp(0)
Next i
InexMatchV2 = Join(Arr, Chr(10))
Related
In order to use TEXTJOIN in excel 2016, I used this public function in my excel but after restarting my PC I get name error when this function used to work. I created a new module and copied and pasted the text as is
How to replicate Excel's TEXTJOIN function in VBA UDF that allows array inputs
I have to specify the file I am working in and the module and then the function again for it to work. aka =testfile!tjoin.tjoin(function parameters)
Public Function TJoin(Sep As String, ParamArray TxtRng() As Variant) As String
On Error Resume Next
'Sep is the separator, set to "" if you don't want any separator. Separator must be string or single cell, not cell range
'TxtRng is the content you want to join. TxtRng can be string, single cell, cell range or array returned from an array function. Empty content will be ignored
Dim OutStr As String 'the output string
Dim i, j, k, l As Integer 'counters
Dim FinArr(), element As Variant 'the final array and a temporary element when transfering between the two arrays
'Go through each item of TxtRng(), depending on the item type, transform and put it into FinArray()
i = 0 'the counter for TxtRng
j = 0 'the counter for FinArr
k = 0: l = 0 'the counters for the case of array from Excel array formula
Do While i < UBound(TxtRng) + 1
If TypeName(TxtRng(i)) = "String" Then 'specified string like "t"
ReDim Preserve FinArr(0 To j)
FinArr(j) = "blah"
FinArr(j) = TxtRng(i)
j = j + 1
ElseIf TypeName(TxtRng(i)) = "Range" Then 'single cell or range of cell like A1, A1:A2
For Each element In TxtRng(i)
ReDim Preserve FinArr(0 To j)
FinArr(j) = element
j = j + 1
Next
ElseIf TypeName(TxtRng(i)) = "Variant()" Then 'array returned from an Excel array formula
For k = LBound(TxtRng(0), 1) To UBound(TxtRng(0), 1)
For l = LBound(TxtRng(0), 2) To UBound(TxtRng(0), 2)
ReDim Preserve FinArr(0 To j)
FinArr(j) = TxtRng(0)(k, l)
j = j + 1
Next
Next
Else
TJoin = CVErr(xlErrValue)
Exit Function
End If
i = i + 1
Loop
'Put each element of the new array into the join string
For i = LBound(FinArr) To UBound(FinArr)
If FinArr(i) <> "" Then 'Remove this line if you want to include empty strings
OutStr = OutStr & FinArr(i) & Sep
End If
Next
TJoin = Left(OutStr, Len(OutStr) - Len(Sep)) 'remove the ending separator
End Function
I'm trying to turn general data written as fractions like 3/4" or 13 7/32" into 3 place decimal numbers such as 0.750 or 13.219.
I have a working table replacement that handles 0 to 1" fractions. It can't handle the mixed numbers like 13 7/32". It leaves me with 13 0.219 which is why I need to replace " 0." with "." to join the 13 and 219 together with a decimal.
We do this data conversion in multiple steps and hand type because Excel tries converting some fractions like 3/4" into a date.
Original data
Resulting data
Sub FractionConvertMTO()
'this section works
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
Selection.Replace what:=Cells(i, 21).Value, Replacement:=Cells(i, 22).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next
'this section doesn't work
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
str1 = " "
str1 = Trim(Replace(str1, " ", "+"))
Next
'this section changes the format.
For i = 66 To 130
Range("F6:H48").NumberFormat = "0.000"
Next
'this section is supposed to add an = sign in front of the cell contents but doesn't work.
Dim Cell As Range
For Each Cell In Range("F6:H48")
Cell.Value = "=" & Cell.Value
Next Cell
'this section works to highlight the first cell
Worksheets("BOM").Cells(1, 1).Select
End Sub
I dug up the following method from my library of useful functions. It converts numbers represented as a fractional string to the numeric equivalent. Simply loop through the cells needing conversion and call this method:
Public Function FractionToNumber(ByVal Value As String, Optional ByVal Digits As Long = 0) As Double
Dim P As Integer
Dim N As Double
Dim Num As Double
Dim Den As Double
Value = Trim$(Value)
P = InStr(Value, "/")
If P = 0 Then
N = Val(Value)
Else
Den = Val(Mid$(Value, P + 1))
Value = Trim$(Left$(Value, P - 1))
P = InStr(Value, " ")
If P = 0 Then
Num = Val(Value)
Else
Num = Val(Mid$(Value, P + 1))
N = Val(Left$(Value, P - 1))
End If
End If
If Den <> 0 Then N = N + Num / Den
FractionToNumber = Round(N, Digits)
End Function
You may also code something like the following:
Sub FractionConvertMTO()
Dim rng As Range
Dim Arr As Variant
Arr = Worksheets("MTO").Range("F6:H48")
For Row = 1 To UBound(Arr, 1)
For col = 1 To UBound(Arr, 2)
str1 = Arr(Row, col)
pos1 = InStr(str1, " ")
pos2 = InStr(str1, "/")
If pos2 = 0 Then
N = val(str1)
Num = 0: Den = 1
Else
If pos1 And pos1 < pos2 Then
N = val(Left$(str1, pos1 - 1))
Num = val(Mid$(str1, pos1 + 1))
Else
N = 0
Num = val(Left$(str1, pos2 - 1))
End If
Den = val(Mid$(str1, pos2 + 1))
End If
Arr(Row, col) = N + Num / Den
Next col
Next Row
Worksheets("MTO").Range("F6", "H48") = Arr
End Sub
If you dispose of the newer dynamic array features (vers. 2019+,MS365) you might write the results in one go to the entire original range (target range) as follows (overwriting the existing range; otherwise define a given offset to identify another target range: rng.Offset(,n)=..).
Tip: make a backup copy before testing (as it overwrites rng)!
Note that this example assumes the " character (asc value of 34).
A) First try via tabular VALUE() formula evaluation
Caveat: converting blanks by VALUE() would be written as #VALUE! results, which would need a further loop. To avoid this you can prefix a zero to the formulae myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))" so that results would be displayed as zero.
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) define tabular formula
Dim myFormula As String
'myFormula = "=VALUE(SUBSTITUTE(" & rng.Address & ","""""""",""""))"
'Alternative to avoid #VALUE! displays for blanks:
myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))"
'Debug.Print myFormula
'3) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value2 = rng.Parent.Evaluate(myFormula)
End Sub
Conclusion due to comment:
Though fast, this approach has a big disadvantage: Excel interpretes date-like numbers as such, transforms them internally to dates by returning the numeric part here, so a cell input of 3/4" would return the corresponding date value of the current year for March 4th.
B) Reworked code based on direct cell evaluations in a loop //Edit
Similar to the above processing this approach is also based on evaluation, but collects all formulae as strings in a variant datafield array v, which allows to manipulate and evaluate each cell input individually:
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) assign formula strings to variant 1-based 2-dim data field array
Dim v As Variant
v = rng.Formula2
'3) evaluate results in a loop
Dim i As Long, j As Long
For i = 1 To UBound(v)
For j = 1 To UBound(v, 2)
v(i, j) = Evaluate("0" & Replace(v(i, j), Chr(34), ""))
Next j
Next i
'4) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value = v
End Sub
str1 = trim(Replace(str1, "0.", "."))
I want to loop thru an array and extract its delimited values that match every date in a range. For e.g., in the picture below:
I have a date range, say 01-01 to 01-10.
I also have a list of strings (see second pic).
In the array below (see first pic), I have three different values delimited by a semi-colon.
For all matching strings (from second pic) e.g., SISBTXTRPR-(number) and date, I want to extract the last part of the array value.
Picture 1
Picture 2
So, for all array values that match "SISBTXTRPR-4649" (the string from picture 2) and a date (in this case 12-12), I want to extract "2h" from the array. The date range for each string, in this case, "SISBTXTRPR-4649" will be 10 days. I am racking my brain on how to do this :(
This is all I could come up with so far:
While i < UBound(sTimeStamp)
If StrComp(Trim(Format(Now(), "MM-DD")), Trim(Split(sTimeStamp(9), ";")(1))) = 0 And StrComp(Trim(Worksheets("KPIs").Range("AN" & iCounter)), Trim(Split(sTimeStamp(1), ";")(0))) Then
End If
i = i + 1
Wend
Link to file
Sample File
The next code will return occurrences for each string in 'Task' range matching the date from its corresponding 'sTimeStamp Array' string with the one from the 'Date Range Array'. Each occurrence will be add to the next column of 'Task' string column:
Private Sub findOccurrences()
Dim sTask As Worksheet, sStamp As Worksheet, sDate As Worksheet
Dim arrTask As Variant, arrStamp As Variant, arrDate As Variant
Dim i As Long, j As Long, arrS As Variant, El As Variant, dtRef As Date
Set sTask = ThisWorkbook.Sheets("Task")
Set sStamp = ThisWorkbook.Sheets("sTimeStamp Array")
Set sDate = ThisWorkbook.Sheets("Date Range Array")
arrTask = sTask.Range("A2:A" & sTask.Range("A" & sTask.Rows.Count).End(xlUp).Row).Value
arrStamp = sStamp.Range("A2:A" & sStamp.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Value
arrDate = sDate.Range("A2:A" & sDate.Range("A" & sDate.Rows.Count).End(xlUp).Row).Value
'____________________________________________________________________________
sTask.Range("B2:K" & sTask.Range("A" & sTask.Rows.Count).End(xlUp).Row).Clear
Do While i < UBound(arrStamp)
i = i + 1
arrS = Split(arrStamp(i, 1), ";")
For j = 1 To UBound(arrTask)
If arrS(0) = arrTask(j, 1) Then
For Each El In arrDate
dtRef = DateValue(Format(El, "MM-DD"))
If dtRef = DateValue(Format(arrS(1), "MM-DD")) Then
Debug.Print arrS(0) & " (row number " & j + 1 & "), interval """ & _
El & """ exists."
sTask.Cells(j + 1, sTask.Cells(j + 1, _
sTask.Columns.Count).End(xlToLeft).Column).Offset(0, 1).Value = El
End If
Next
End If
Next j
Loop
End Sub
And the short variant working similar to your approach, finding the occurrences for Today date (if I correctly deduced what you intended to achieve), replace the looping part with this:
'______________________________________________________________________________
sStamp.Range("B2:B" & sStamp.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Clear
sTask.Range("A2:A" & sTask.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Interior.ColorIndex = -4142
While i < UBound(arrStamp)
i = i + 1
If StrComp(DateValue(Format(Date, "MM-DD")), DateValue(Split(arrStamp(i, 1), ";")(1))) = 0 And _
Not isMatchErr(CStr(Split(arrStamp(i, 1), ";")(1)), arrDate) Then
Debug.Print "OK for """ & Split(arrStamp(i, 1), ";")(0) & """ of row """ & i & """."
sStamp.Range("B" & i + 1).Value = "OK"
If Not isMatchErr(CStr(Split(arrStamp(i, 1), ";")(0)), arrTask) Then
rowOK = WorksheetFunction.Match(Split(arrStamp(i, 1), ";")(0), arrTask, 0) + 1
sTask.Range("A" & rowOK).Interior.ColorIndex = 3
End If
End If
Wend
And add the next function:
Function isMatchErr(strTime As String, arrDate As Variant) As Boolean
Dim k As Long
On Error Resume Next
k = WorksheetFunction.Match(strTime, arrDate, 0)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0: isMatchErr = True
End If
On Error GoTo 0
End Function
Besides the message in Immediate Window, an "OK" will be put on column B:B for all occurrences (in 'sTimeStamp Array' sheet) and background of the matching cell (in 'Task' sheet will be colored in red... In order to do that, I added a new record and modified an existing cell, for "Today" ("01-12"). Please do the same in order to obtain at least two results in column B:B.
Please confirm that this is what you wanted. If not, please better clarify the need...
I have a shared excel sheet with records being entered all the time. I want to find the last consecutive entry of a specific Name(its 'A' in this example) and record the value at the begining and ending of last occurance.
The output of the attached excel should be
A,2,34 ---when i open when there were 5 entries
A,5,null ---when i opened when there were 9 entries
A,9,6 ---when i opened when there were 11 entries
A,9,3 ---when i opened when there were 12 entries
please help me with the formula that i can use in a different tab of same excel.
Thanks
this should work.
in column C use this formula. Works from row2 and down. row1 should be irrelevant (no consecutive entries at this point).
=IF(B1=B2,B2&","&A1&","&A2,"")
You can also have a formula display whatever is the last entry for that value. This is for value "A".
=LOOKUP(2,1/(B:B=E1),C:C)
A UDF should be able to handle the relative loop.
Option Explicit
Function LastConColVals(rng As Range, crit As String, _
Optional delim As String = ",")
Dim tmp As Variant, r As Long, rr As Long
'allow full column references
Set rng = Intersect(rng, rng.Parent.UsedRange)
With rng
tmp = Array(crit, vbNullString, vbNullString)
For r = .Rows.Count To 1 Step -1
If .Cells(r, 2).Value = crit Then
tmp(2) = .Cells(r, 1).Value
For rr = r To 1 Step -1
If .Cells(rr, 2).Value = crit Then
tmp(1) = .Cells(rr, 1).Value
Else
Exit For
End If
Next rr
'option 1 - null last value for singles
If rr = (r - 1) Then tmp(2) = "null"
'option 2 - truncate off last value for singles
'If rr = (r - 1) Then ReDim Preserve tmp(UBound(tmp) - 1)
Exit For
End If
Next r
End With
LastConColVals = Join(tmp, delim)
End Function
I am hoping someone could help me out with a VBA Excel macro.
I have received a worksheet in Excel 2007 which contains product names in one column, and I need to sort this into a logical format so I can use it. However, the list itself is not in any kind of logical order, is 10 000 rows long and I am going to have to do this every month!!
Basically, what I would like to do is search for certain keywords which are common to most of the entries and move them into separate cells in different columns (but in the same row as the original entry).
Regarding keywords: There are 3 different types, two of which I have a complete list of.
Example of keywords: some are measures such as cm (centimetre), mm (millimetre), m (metre) etc.). Then there are other keywords such as % and finally a last set of keywords which is wood, plastic, glass etc.
If this was not complicated enough, the measures (cm for example) are duplicated in some instances and are important details so I cant just separate them but would ideally like them in two adjacent cells.
Fortunately, there is a space after each measure, % sign and item material.
Working from right to left is the easiest way I can think of achieving this as the first description in the string varies wildly between entries and that can stay as is.
So, below is an example string, lets say this is in Cell A1. (Inverted commas are not included in the string and the word "by" appears in only about 100 cases. Usually it is missing...)
"Chair Leg Wood 100% 1m by 20cm"
I would ideally like for the string to be split up into cells as follows
Cell B1 - Chair Leg
Cell C1 - Wood
Cell D1 - 1m
Cell E1 - 2cm
Cell F1 - 100%
Having the % measures in the same column would be extremely helpful
Can anyone please help me with this or the beginnings of a macro which does this and then moves down the list - I have tried using some basic "find" and "len" formulas but really am at my wits end on how to deal with this!
The task boils down to defining a robust definition of the structure of the input data.
Form the info provided a candidate definition might be
<Description, one or more words> <Material, one word> <A value followd by %> <Dimension A> <optional "by"> <Dimension B>
The following macro will process data that conforms this this spec. The definition may need
expanding, eg two word materials (eg Mild Steel)
You will need to add error handling in case any rows don't conform, eg no % in the string, or % character elsewhere in string
Option Explicit
Dim dat As Variant
Sub ProcessData()
Dim r As Range
Dim i As Long
Set r = Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns(1)).Resize(, 5)
dat = r
For i = 1 To UBound(dat, 1)
ParseRow i, CStr(dat(i, 1))
Next
r = dat
ActiveSheet.Columns(5).Style = "Percent"
End Sub
Sub ParseRow(rw As Long, s As String)
'Chair Leg Wood 100% 1m by 20cm
Dim i As Long
Dim sDim As String, sPCnt As String, sMat As String, sDesc As String
Dim sA As String, sB As String
i = InStr(s, "% ")
sDim = Trim(Replace(Mid(s, i + 2), " by ", " ")) ' text to right of %, remove "by"
sA = Trim(Left(sDim, InStr(sDim, " "))) ' split dimension string in two
sB = Trim(Mid(sDim, InStr(sDim, " ")))
s = Left(s, i)
i = InStrRev(s, " ")
sPCnt = Mid(s, i + 1) ' text back to first space before %
s = Trim(Left(s, i))
i = InStrRev(s, " ") ' last word in string
sMat = Mid(s, i + 1)
sDesc = Trim(Left(s, i)) ' whats left
dat(rw, 1) = sDesc
dat(rw, 2) = sMat
dat(rw, 3) = sA
dat(rw, 4) = sB
dat(rw, 5) = sPCnt
End Sub
First, I'd use the Split function to separate the parts into an array, this will avoid most of the string functions and string math:
Dim parts As Variant
parts = Split(A1)
Then, I'd do my comparisons to each part.
Finally, I'd concatenate the parts I didn't breakout, and place all parts on the sheet.
This is based on your example which has spaces inbetween every part, though something similar could work otherwise, you just have to do more work with each part.
Here's my stab at it. We could use about 10 more examples, but this should be a start. To use, select a one column range with your descriptions and run SplitProduct. It will split it out to the right of each cell.
Sub SplitProducts()
Dim rCell As Range
Dim vaSplit As Variant
Dim i As Long
Dim aOutput() As Variant
Dim lCnt As Long
Const lCOLDESC As Long = 1
Const lCOLMAT As Long = 2
Const lCOLPCT As Long = 3
Const lCOLREM As Long = 4
If TypeName(Selection) = "Range" Then
If Selection.Columns.Count = 1 Then
For Each rCell In Selection.Cells
'split into words
vaSplit = Split(rCell.Value, Space(1))
ReDim aOutput(1 To 1, 1 To 1)
'loop through the words
For i = LBound(vaSplit) To UBound(vaSplit)
Select Case True
Case IsPercent(vaSplit(i))
'percents always go in the same column
lCnt = lCOLPCT
If UBound(aOutput, 2) < lCnt Then
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
End If
aOutput(1, lCnt) = vaSplit(i)
Case IsInList(vaSplit(i))
'list items always go in the same column
lCnt = lCOLMAT
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
If UBound(aOutput, 2) < lCnt Then
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
End If
aOutput(1, lCnt) = vaSplit(i)
Case IsMeasure(vaSplit(i))
'measurements go in the last column(s)
If UBound(aOutput, 2) < lCOLREM Then
lCnt = lCOLREM
Else
lCnt = UBound(aOutput, 2) + 1
End If
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
aOutput(1, lCnt) = vaSplit(i)
Case Else
'everything else gets concatentated in the desc column
aOutput(1, lCOLDESC) = aOutput(1, lCOLDESC) & " " & vaSplit(i)
End Select
Next i
'remove any extraneous spaces
aOutput(1, lCOLDESC) = Trim(aOutput(1, lCOLDESC))
'write the values to the left of the input range
rCell.Offset(0, 1).Resize(1, UBound(aOutput, 2)).Value = aOutput
Next rCell
Else
MsgBox "Select a one column range"
End If
End If
End Sub
Function IsPercent(ByVal sInput As String) As Boolean
IsPercent = Right$(sInput, 1) = "%"
End Function
Function IsInList(ByVal sInput As String) As Boolean
Dim vaList As Variant
Dim vaTest As Variant
'add list items as needed
vaList = Array("Wood", "Glass", "Plastic")
vaTest = Filter(vaList, sInput)
IsInList = UBound(vaTest) > -1
End Function
Function IsMeasure(ByVal sInput As String) As Boolean
Dim vaMeas As Variant
Dim i As Long
'add measurements as needed
vaMeas = Array("mm", "cm", "m")
For i = LBound(vaMeas) To UBound(vaMeas)
'any number of characters that end in a number and a measurement
If sInput Like "*#" & vaMeas(i) Then
IsMeasure = True
Exit For
End If
Next i
End Function
No guarantees that this will be speedy on 10k rows.