I have received a worksheet in Excel which contains kids names and video time tags all in one column, and I need to sort this into a logical format so I can use it. However, the list has no separators.. So I am hoping someone could help me out with a VBA Excel macro.
Below is an example (shortened) string, lets say this is in Cell A1.
" Sandy 25:1132:27Giorgio
09:1114:7Anne Marie 32:10David 17:48Marty
04:3506:1010:3613:1014:32Sandy (2) 04:30Brian 13:4714:37"
I would ideally like for the string to be split up into cells as follows
Cell A2 Sandy
Cell A3 25:11
Cell A4 32:27
Cell A5 Giorgio
Cell A6 09:11
Cell A7 14:7
Cell A8 Anne Marie
Cell A9 32:10
Cell A10 David
Cell A11 17:48
Cell A12 Marty
Cell A13 04:35
Cell A14 06:10
Cell A15 10:36
Cell A16 13:10
Cell A17 14:32
Cell A18 Sandy (2)
Cell A19 04:30
Cell A20 Brian
Cell A21 13:47
Cell A22 14:37
I have tried using some basic "find" and "len" formulas but no luck..
Doesn't do exactly what you want - but it may help get you going in a direction... Hopefully it'll turn out to be the right one...
I pasted your string into cell A1 in my worksheet and then wrote this code in a module in the sheet:-
Function parseText(ByVal text As String, ByVal domain As Integer) As String
Dim returnValue As String
Dim colon As Integer
Dim soFar As Integer
soFar = 0
text = Trim(text)
While soFar < domain
colon = InStr(text, ":")
While (Mid(text, colon + 5, 1) = ":")
colon = colon + 5
Wend
returnValue = Mid(text, 1, colon + 2)
While Not (IsNumeric(Right(returnValue, 1)))
returnValue = Left(returnValue, Len(returnValue) - 1)
Wend
text = Replace(text, returnValue, "")
soFar = soFar + 1
Wend
parseText = returnValue
End Function
Function parseDomain(ByVal domain As String) As String
Dim returnValue As String
Dim part As String
While Len(domain) > 0
part = ""
If InStr(domain, ":") > 0 Then
part = Mid(domain, InStrRev(domain, ":") - 2, 5)
returnValue = part & "~" & returnValue
domain = Left(domain, Len(domain) - Len(part))
End If
If part = "" Then
returnValue = Trim(domain) & "~" & Left(returnValue, Len(returnValue) - 1)
domain = ""
End If
Wend
parseDomain = returnValue
End Function
Function pullPiece(ByVal block As String, ByVal piece As Integer) As String
Dim returnValue As String
Dim pieces() As String
pieces = Split(block, "~")
If piece > UBound(pieces) + 1 Then
returnValue = ""
Else
returnValue = pieces(piece - 1)
End If
pullPiece = returnValue
End Function
This bit is complicated to explain...
In the image below the formula in A14 is the content of cell A4. The formula in A15 is the content of cell A5, etc. all the way down to A10. These formulae break out the block of text for each name.
The formula in B14 is the content of B4. This cell can then be copied down the range to B10 so that the references change to A4 thru A10. These formulae reformat the text with tildes so that the text is easier to split up (later).
The formula in C14 is the contents of C4. This cell can be copied down to C10. This pulls the name from the block it relates to. The second parameter is the "piece" number - 1=name, 2=time1, 3=time2, etc.
The formula in D14 is the contents of cells D4 and pulls the first time out of the block it relates to. I haven't put the definition for the other formulae - but hopefully you can see the pattern on how they are used.
Drop me a message if you want any clarification.
The string is difficult to parse due to the timestamps not appearing to follow a similar format. For example most follow the format 00:00, however the value you wish to place in cell A7 only has a single digit following the colon. I have therefore created some code to get you started in the right direction, but this works on the assumption of the format 00.00 and currently doesn't parse text following numbers. But if you perform a bit more research I'm sure you can complete from this point:
Public Sub TestCode()
Dim strTest As String, strModify() As String, strNew() As String, x As Long
strTest = "Sandy 25:1132:27Giorgio 09:1114:7Anne Marie 32:10David 17:48Marty 04:3506:1010:3613:1014:32Sandy (2) 04:30Brian 13:4714:37"
strModify = Split(strTest)
ReDim strNew(0 To 0)
strNew(0) = strModify(0)
For x = 1 To UBound(strModify)
If Left(strModify(x), 1) Like "[A-Z]" Then
ReDim Preserve strNew(0 To (UBound(strNew) + 1))
strNew(UBound(strNew)) = strModify(x)
ElseIf Left(strModify(x), 1) Like "[0-9]" Then
Do Until InStr(1, strModify(x), ":") = 0
ReDim Preserve strNew(0 To (UBound(strNew) + 1))
strNew(UBound(strNew)) = Left(strModify(x), InStr(1, strModify(x), ":") + 2)
strModify(x) = Right(strModify(x), Len(strModify(x)) - (InStr(1, strModify(x), ":") + 2))
Loop
Else
strNew(UBound(strNew)) = strNew(UBound(strNew)) & " " & strModify(x)
End If
Next x
For x = 0 To UBound(strNew)
Range("A1").Offset(0, x).Value = strNew(x)
Next x
End Sub
To help you understand the code in order to modify, this is basically splitting the original string wherever there is a space (result placed in array called strModify). It then checks the first character in the string to see if it is a letter, number or other character. Based on this information it will place the individual components of the string in to a new array variable called strNew. It then simply reads this array and places each item in to the next available cell.
I hope this helps you begin. Once you have a solution please post your final code on here in order to help others who may have a similar problem.
Related
I have two cells with numbers i.e. A1 and B1. I need a formula to get the digits in A1 which are present in B1 to be shown in cell B2.
In below example, all digits in A1 i.e. 5,3,9,4 are found in B1 and therefore shall be shown in cell B2
cell A1 = 5394
cell B1 = 7284395
cell B2 = 5394 [formula result]
Thank you
The below code will work. It divides the SearchTerm into individual character strings called SearchTerm_Individual based on the length of the SearchTerm. The code further appends the individual characters to the result cell, if found in the SearchIn String.
Option Explicit
Sub Search_Item2()
Dim SearchTerm As String
Dim SearchIn As String
Dim SearchTerm_Length As Integer
Dim X As Byte
SearchTerm = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
SearchIn = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
SearchTerm_Length = Len(SearchTerm)
Dim SearchTerm_Individual() As String
ReDim SearchTerm_Individual(1 To SearchTerm_Length) As String
For X = 1 To SearchTerm_Length
SearchTerm_Individual(X) = Mid(SearchTerm, X, 1)
If InStr(SearchIn, SearchTerm_Individual(X)) > 0 Then
ThisWorkbook.Sheets("Sheet1").Range("C1").Value = ThisWorkbook.Sheets("Sheet1").Range("C1").Value & SearchTerm_Individual(X)
End If
Next X
End Sub
The function below will work but is limited to 4 characters in A1.
=IF(AND(ISNUMBER(FIND(MID(A1, 1, 1), B1)), ISNUMBER(FIND(MID(A1, 2, 1), B1)), ISNUMBER(FIND(MID(A1, 3, 1), B1)), ISNUMBER(FIND(MID(A1, 4, 1), B1))), A1, "")
This looks at each character in A1 using MID(). It passes that to FIND() to see if that character is in B2. It uses ISNUMBER() around FIND() to see if it's getting a valid numerical result. In this case it's easier than checking for an error. It uses AND() to check that all 4 characters are in B2.
Again, this will work but is not flexible at all regarding the length if the text in A1. You likely want something different. Please share more info about what you're trying to accomplish.
I'm trying to obtain a column that will contain the index number of first word from the referenced column cell by cell.
I am able to get the length of word in a text, for upper cell value in have used ActiveCell.Offset(-1, 0).Activate but it does not work for me.
Public Function StartIndex(ByVal strText As String) As Long
Application.Volatile
Length = UBound(Split(strText, " ")) + 1
StartIndex = ActiveCell.Offset(-1, 0).Activate + Length
End Function
look below, consider I'm having col1 by default and want startIndex through VBA;
Col1 | startIndex
VBA Index Printer Friendly version | 1
Adobe Acrobat version | 6
A UDF can remain in a code module | 9
as shown above consider the table have 3 rows and two columns,the index number of word "VBA"**in col1 row1 is 1 similarly word **"is" next to word "VBA" have an index of 2, and so on .. Consider the rows are a combination of a paragraph and so when we reach Col1 row2 the index of word "Adobe" should be 6 as shown in table
Actually startIndex column shows the index number of the first word from the paragraph which is divided in rows
No need for VBA just use a formula to count the words:
Then add the amount of words to the previous amount of words (from the row above).
Write 1 into B1 (it is always 1)
Use the following formula in B2:
=B1+LEN(TRIM(A1))-LEN(SUBSTITUTE(TRIM(A1)," ",""))+1
Copy the formula from B2 to B3
I've modified your original Function a litte bit, to be able to handle ranges:
Public Function StartIndex(ByVal vRNG As Range) As Long
Application.Volatile
Dim rng As Range
For Each rng In vRNG
StartIndex = UBound(Split(rng.Value, " ")) + 1 + StartIndex
Next rng
End Function
Then, you can apply it like this:
=StartIndex($A$1:A1)+1
But to make it work you need to apply it from row 2....
Another option would be to input in B1 just a 1 (because it always going to be 1) and then in B2, same formula:
=StartIndex($A$1:A1)+1
And it would work:
I'd approach this slightly differently and pass the range instead.
Public Function StartIndex(ByVal textCell As Range) As Long
Dim text As String
text = textCell.Value
Dim result As Long
result = (UBound(Split(text, " ")) + 1)
If textCell.Row > 1 Then
result = result - (UBound(Split(textCell.Offset(-1, 0).Value, " ")) + 1)
End If
StartIndex = result
End Function
example use:
=StartIndex(A1)
or in VBA:
Dim index As Long
index = StartIndex(Range("A1"))
I have a scenario where I have to read through values in one cell which is comma separated and retrieve only values from that array to match with a particular lookup value. For eg:
So what I need is a function to retrieve all Task(or any other issuetype which could vary) from row 2 Links column
expected result: Against A2 I want to retrieve A4 and A6
This is something I modified so that you could customize it to any lookup value
Function GetLinkedItem(link As String, targetLinkType As String)
Dim temp(0 To 0) As String
GetLinkedItem = "None"
If Trim(link) = "" Then Exit Function
Dim links() As String, i As Long
links = Split(link, ",")
For i = 0 To UBound(links)
'select the links that are targetLinkType
Dim j As Long
j = GetRow(Trim(links(i)))
If Sheets("Data").Cells(j, ISUUETYPE_COL) = targetLinkType Then
temp(0) = temp(0) & " " & Sheets("Data").Cells(j, ID_COL) & ","
End If
GetLinkedItem = Join(temp, ",")
Next i
End Function
You can create a UDF to perform this lookup. In a new module in your VBE, paste the following:
Function getTasks(tasklist As Range, availabletasks As Range) As String
'tasklist is the incoming array in Column C
'availabletasks is the stuff in Column A
'Array for output
Dim tasks() As String: ReDim tasks(0 To 0)
'Loop through each item in taslist using an array
For Each task In Split(tasklist.Value, ", ")
'Search availabletasks
If Not availabletasks.Find(task) Is Nothing Then
'pop the array
If tasks(0) <> "" Then ReDim Preserve tasks(0 To UBound(tasks) + 1)
tasks(UBound(tasks)) = task
End If
Next
'Return what we found
getTasks = Join(tasks, ", ")
End Function
Now in your spreadsheet you can use this function just like a regular formula:
=getTasks(C1,$A$1:$A$6)
Where C1 has the list like A4, A25, A22, A6, A29, A42 and $A$1:$A$6 are just like your example Column A. This will return A4, A6
Thanks so much. I added the code in a new module and used the function as formula. I was getting just 1 value instead of 2(Just got A4 and not A6).
i have text content in the first cell of each row. it is basically a paragraph. i want to split this paragraph into different cells, in the same row.
Definition: Photosynthesis is a process used by plants and other organisms to convert light energy, normally from the Sun, into chemical energy that can be later released to fuel the organisms activities. Working: In photosynthetic bacteria, the proteins that gather light for photosynthesis are embedded in cell membranes. In its simplest form, this involves the membrane surrounding the cell itself. Evolution: Early photosynthetic systems, such as those from green and purple sulfur and green and purple nonsulfur bacteria, are thought to have been anoxygenic, using various molecules as electron donors.
this content is present in cell a1. i want to split it into 3 cells
cell a2
"Definition: Photosynthesis is a process used by plants and other organisms to convert light energy, normally from the Sun, into chemical energy that can be later released to fuel the organisms activities."
cell a3
"Working: In photosynthetic bacteria, the proteins that gather light for photosynthesis are embedded in cell membranes. In its simplest form, this involves the membrane surrounding the cell itself."
cell a4
"Evolution: Early photosynthetic systems, such as those from green and purple sulfur and green and purple nonsulfur bacteria, are thought to have been anoxygenic, using various molecules as electron donors."
first cell goes on from text Definition: ---- Working: (this includes the text "Definition:" and does not include "Working:")
second cell goes on from Working: ------- Evolution: (this includes the text "Working:" and does not include "Evolution:")
third cell from Evolution: ------- endof string.
Being that you tagged this as Excel-vba also I thought I would post a VBA solution for you. This UDF hopefully covers your needs.
Function SplitString(MyString As String, PartNum As Long)
Dim MyNewString As String, DefNames As Variant, DefNamesOn As Boolean
DefNamesOn = True
DefNames = Array("Definition: ", "Working: ", "Evolution: ")
MyNewString = Split(MyString, ":")(PartNum)
If DefNamesOn Then
SplitString = DefNames(PartNum - 1)
Else
SplitString = ""
End If
If Right(UCase(MyNewString), 8) = " WORKING" Then
SplitString = SplitString & Trim(Left(MyNewString, Len(MyNewString) - 8))
ElseIf Right(UCase(MyNewString), 10) = " EVOLUTION" Then
SplitString = SplitString & Trim(Left(MyNewString, Len(MyNewString) - 10))
Else
SplitString = SplitString & Trim(MyNewString)
End If
End Function
You can change DefNamesOn = True to False if you don't want "Definition: ", "Working: " or "Evolution: " at the start
Use it like any other formula: =SplitString(A1,1) where A1 has your string and 1 is the number of the part you want (1, 2 or 3)
You can chop a bit out of the code if you always want DefNames on or off but I thought it better to give you the option in the code.
Another VBA solution:
Option Explicit
Public Sub extractPara()
Dim lRow As Long, ur As Variant, arr As Variant
Dim i As Long, j As Long, x2 As Long, x3 As Long
With ActiveSheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row: j = 1
ur = .Range("A1:A" & lRow).Value2
arr = .Range("A1:A" & lRow * 4).Value2
For i = 1 To lRow
x2 = InStr(1, ur(i, 1), "Working:", vbBinaryCompare)
x3 = InStr(1, ur(i, 1), "Evolution:", vbBinaryCompare)
arr(j + 0, 1) = ur(i, 1)
arr(j + 1, 1) = Left(ur(i, 1), x2)
arr(j + 2, 1) = Mid(ur(i, 1), x2, x3)
arr(j + 3, 1) = Mid(ur(i, 1), x3)
j = j + 4
Next
.Range("A1:A" & lRow * 4) = arr
End With
End Sub
Using FIND() and MID() you should be able to parse this.
Disclaimer: The solution below assumes that you will always have the strings "Definition", "Working", and "Evolution" in each paragraph you wish to parse.
FIND returns a number based on the position of the character starting from the designated position, in this case, the first character, 1.
In A2 use this formula:
=LEFT(A1,FIND("Working:",A1,1)−1)
This searches for "Working:" and returns its position. In this case character number 206. The -1 omits the "W" in working from being returned as it is character #206. We want to end at the character before "W".
In A3 use this formula:
=MID(A1,FIND("Working:",A1,1),FIND("Evolution:",A1,1)-FIND("Working:",A1,1))
Now we are looking for a start and end character position. We have to use subtraction to get the string length.
In A4 use this formula:
=MID(A1,FIND("Evolution:",A1,1),FIND("Working:",A1,1))
Middle requires a start and end character position.
Bonus: to eliminate any extra white space at the beginning or end, wrap the formulas in the TRIM() function. Exampple: =TRIM(MID(A1,FIND("Working:",A1,1),FIND("Evolution:",A1,1)-FIND("Working:",A1,1)))
googled alot about this.
got something that worked for me.
=MID(A1,SEARCH("Definition:",A1),SEARCH("Working:",A1)-SEARCH("Definition:",A1))
this got me the result in cell a2
Working: In photosynthetic bacteria, the proteins that gather light for photosynthesis are embedded in cell membranes. In its simplest form, this involves the membrane surrounding the cell itself.
Let's say I have a series of cells like so:
A
1 Foo
2 Bar
3 Hello
4 World
5 Random Text
What I'd like to do is have the result of my formula populate another cell with:
Foo, Bar, Hello, World, Random Text
Now, I know how to concatenate two cells with:
=A1&", "&A2
but how can I do the same thing with the entire series?
Here's a function you might be able to use. Simply put this in your workbook code module, then you can enter it in cells like:
=JoinRange(A1:A6) or =JoinRange(A2:D15), etc.
Public Function JoinRange(ByVal rng As Range) As String
Dim dlmt As String: dlmt = ","
Dim multiRow As Boolean: multiRow = rng.Rows.Count > 1
Dim r As Long, c As Long
Select Case rng.Columns.Count
Case 1
If multiRow Then
JoinRange = Join(Application.WorksheetFunction.Transpose(rng), dlmt)
Else:
'a single cell
JoinRange = rng
End If
Case Is > 1
If multiRow Then
'a 2d range of cells:
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
JoinRange = JoinRange & rng(r, c) & dlmt
Next
Next
JoinRange = Left(JoinRange, Len(JoinRange) - 1)
Else:
JoinRange = Join(Application.WorksheetFunction.Transpose( _
Application.WorksheetFunction.Transpose(rng)), dlmt)
End If
Case Else
End Select
End Function
Put a comma and a space in cell B1, then use this formula:
=CONCATENATE(A1,B1,A2,B1,A3,B1,A4, B1, A5)
There are several answers to the following question that you can try as well, including VBA options and a formula:
Need to concatenate varying number of cells...
With =A1 in B1 then =B1&", "&A2 in B2 and copied down would seem to work.