I am trying to separate multiple dates from one cell into multiple cells containing one date in a transposed area and then paste them back over the original area as separate entries.
An example cell might have dates stored like 10/1110/1110/13 or 10/310/310/410/5.
The second scenario is what is causing the error as there is no leading zero for single digit days like 10/3, for example.
Ideally, the code would separate the dates into separate cells like: 10/11,10/11,10/13 and 10/3,10/4,10/5. When single digits days are present ,however, it comes out completely jumbled up and inaccurate.
Admittedly, I had help from another coworker with this code who is on vacation currently, which is why I am having such trouble understanding this. Is there something I could change to account for single digit days or should I approach this process differently?
Thanks!
'separate column J by "/" and store in transpose area
dim h as variant
dim i as variant
dim j as variant
dim counter as variant
dim stringcheck as variant
dim strInput as variant
dim strCurrent as variant
strInput = Cells(j, 10)
h = 0
For counter = 1 To Len(strInput) - 2
stringcheck = InStr(strInput, "/")
Debug.Print j & stringcheck
If stringcheck <> 0 Then
If Mid(strInput, counter, 1) = "/" Then
Cells(17, i + h) = strCurrent & Mid(strInput, counter, 3)
counter = counter + 2
h = h + 1
strCurrent = vbNullString
Else
Cells(17, i + h) = Cells(j, 10)
strCurrent = strCurrent & Mid(strInput, counter, 1)
End If
'else just paste the value
Else
Cells(17, i) = strInput
End If
Next counter
If all of the months within one cell's mashed up dates can be reasonably assumed to be the same then that could be used as a delimiter to split the mash-up and reassemble it.
Function splitMashUp(str As String, _
Optional splitchr As String = "/", _
Optional delim As String = ", ")
Dim i As Long, tmp As Variant
tmp = Split(str, Left(str, InStr(1, str, splitchr)))
For i = LBound(tmp) + 1 To UBound(tmp)
tmp(i) = Left(str, InStr(1, str, splitchr)) & tmp(i)
Next i
splitMashUp = Mid(Join(tmp, delim), Len(delim) + 1)
End Function
Related
Ok so I have two columns of data as follows
Personalisation Max Char | Personaisation Field
1x15x25 | Initial, Name, Date
Previously I was using the following vba function (As excel16 has no TEXTJOIN)
Function TEXTJOIN(delim As String, skipblank As Boolean, arr)
Dim d As Long
Dim c As Long
Dim arr2()
Dim t As Long, y As Long
t = -1
y = -1
If TypeName(arr) = "Range" Then
arr2 = arr.Value
Else
arr2 = arr
End If
On Error Resume Next
t = UBound(arr2, 2)
y = UBound(arr2, 1)
On Error GoTo 0
If t >= 0 And y >= 0 Then
For c = LBound(arr2, 1) To UBound(arr2, 1)
For d = LBound(arr2, 1) To UBound(arr2, 2)
If arr2(c, d) <> "" Or Not skipblank Then
TEXTJOIN = TEXTJOIN & arr2(c, d) & delim
End If
Next d
Next c
Else
For c = LBound(arr2) To UBound(arr2)
If arr2(c) <> "" Or Not skipblank Then
TEXTJOIN = TEXTJOIN & arr2(c) & delim
End If
Next c
End If
TEXTJOIN = Left(TEXTJOIN, Len(TEXTJOIN) - Len(delim))
End Function
This would change 1x15x25 into 1-1, 2-15, 3-25using the following formula
{=TEXTJOIN(", ",TRUE,ROW(INDIRECT("1:" & LEN(A1)-LEN(SUBSTITUTE(A1,"x",""))+1)) & " - " & TRIM(MID(SUBSTITUTE(A1,"x",REPT(" ",999)),(ROW(INDIRECT("1:" & LEN(A1)-LEN(SUBSTITUTE(A1,"x",""))+1)) -1)*999+1,999)))}
Due to the fact, my original method was not specific enough I've been forced to go back to the drawing board.
From the Above, I am wanting to produce the following.
1-2-Initial, 2-15-Name, 3-25-Date
I am a developer but not in visual basic and the worst part Is I know what I would do with a database and PHP just don't have enough knowledge to transfer that to excel.
So I need to either by formula or function
Take 2 Columns and split by a delimiter
Then count the entries on each (Maybe only one)
Then for each in the range create a new string adding the count-col1-col2
I cannot change the data as its given by the supplier
I have a basic understanding of VBA so explain don't belittle
UPDATED (DATA SNAPSHOTS)
This Example uses the formula above a little-jazzed up.
As you can see each row starts the count again Ignore the Personalization/Message line parts I can add these again later
I am in a mega rush so only whipped this up with one row of values (in A1 and B1)
I hope you can step through to understand it, wrap it in another loop to go through your 6000 rows, and change the msgbox to whatever output area you need... 6000 rows should be super quick:
Sub go()
Dim a() As String
Dim b() As String
Dim i As Long
Dim str As String
' split A1 and B1 based on their delimiter, into an array a() and b()
a() = Split(Range("A1").Value2, "x")
b() = Split(Range("B1").Value2, ",")
' quick check to make sure arrays are same size!
If UBound(a) <> UBound(b) Then Exit Sub
' this bit will need amended to fit your needs but I'm using & concatenate to just make a string with the outputs
For i = LBound(a) To UBound(b)
str = str & i + 1 & "-" & a(i) & "-" & b(i) & vbNewLine
Next i
' proof in the pudding
MsgBox str
End Sub
Sub test()
Dim rngDB As Range
Dim vR() As Variant
Dim i As Long
Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp)) '<~~personaliation Max Char data range
ReDim vR(1 To rngDB.Count, 1 To 1)
For i = 1 To rngDB.Count
vR(i, 1) = textjoin(rngDB(i), rngDB(i, 2))
Next i
Range("c2").Resize(rngDB.Count) = vR '<~ result wil be recorded in Column C
End Sub
Function textjoin(rng1 As Range, rng2 As Range)
Dim vS1, vS2
Dim vR()
Dim i As Integer
vS1 = Split(rng1, "x")
vS2 = Split(rng2, ",")
ReDim vR(UBound(vS1))
For i = LBound(vS1) To UBound(vS1)
vR(i) = i + 1 & "-" & Trim(vS1(i)) & "-" & Trim(vS2(i))
Next i
textjoin = Join(vR, ",")
End Function
THANK YOU FOR ALL OF THE HELP
I went back to the drawing board having seen the above.
I learnt
That my original use of array formula and TEXTJOIN where over the top and hardly simplistic
That I can use VBA just like any other programming code :)
My Solution simplified from Dy.Lee
Function SPLITANDMERGE(arr1 As String, arr2 As String, Optional del1 As String = "x", Optional del2 As String = ",")
'Arr1 Split'
Dim aS1
'Arr2 Split'
Dim aS2
'Value Array'
Dim r()
'Value Count'
Dim v As Integer
'Split The Values'
aS1 = Split(arr1, del1)
aS2 = Split(arr2, del2)
'Count The Values'
ReDim r(UBound(aS1))
'For All The Values'
For v = LBound(aS1) To UBound(aS2)
'Create The String'
r(v) = "Personalisation_Line " & v + 1 & " - " & Trim(aS1(v)) & " Characters - [" & Trim(aS2(v)) & "]"
Next v
'Join & Return'
SPLITANDMERGE = Join(r, ", ")
End Function
I'm still working on it but I now get the following result.
Will Be Adding:
Value Count Comparison (If we have 4 and 5 Values return "-" to be picked up by conditional formatting)
Conditional plural values (If value 2 in the string is 0 then character instead of characters
If there are any pitfalls or errors anyone can see please do enlighten me. Im here to learn.
I am trying to lookup a value and return multiple values (whether it be in the same cell or spread out horizontally pasted in different columns)I have tried the following UDF and continue to get #VALUE as result.
Option Explicit
Function LookupCSVResults(lookupValue As Variant, lookupRange As Range, resultsRange As Range) As String
Dim s As String 'Results placeholder
Dim sTmp As String 'Cell value placeholder
Dim r As Long 'Row
Dim c As Long 'Column
Const strDelimiter = "|||" 'Makes InStr more robust
s = strDelimiter
For r = 1 To lookupRange.Rows.Count
For c = 1 To lookupRange.Columns.Count
If lookupRange.Cells(r, c).Value = lookupValue Then
'I know it's weird to use offset but it works even if the two ranges
'are of different sizes and it's the same way that SUMIF works
sTmp = resultsRange.Offset(r - 1, c - 1).Cells(1, 1).Value
If InStr(1, s, strDelimiter & sTmp & strDelimiter) = 0 Then
s = s & sTmp & strDelimiter
End If
End If
Next
Next
'Now make it look like CSV
s = Replace(s, strDelimiter, ",")
If Left(s, 1) = "," Then s = Mid(s, 2)
If Right(s, 1) = "," Then s = Left(s, Len(s) - 1)
LookupCSVResults = s 'Return the function
End Function
Formula in cell =LookupCSVResults(Lookup Value, Col of Lookup Value, Col of Return Value)
Can anyone help trouble shoot this or have another UDF that will provide similar result? Thanks.
My spreadsheet has a column with value like this string:
some text (text1) some test (text2) (text1)
How do I get all values between parentheses? The result I am looking for is:
text1, text2
Even if text1, text2... testn is present in the cell multiple times, I need it in the result only once.
I found a function GetParen here: Get the value between the brackets
It is helpful, but it gives the fist available value in the parentheses and ignores the rest.
It seems unwieldy to have one User Defined Function for individual entries and another for a collective result of all entries.
Paste the following into a standard module code sheet.
Function getBracketedText(str As String, _
Optional pos As Integer = 0, _
Optional delim As String = ", ", _
Optional dupes As Boolean = False)
Dim tmp As String, txt As String, a As Long, b As Long, p As Long, arr() As Variant
tmp = str
ReDim arr(1 To 1)
For b = 1 To (Len(tmp) - Len(Replace(tmp, Chr(40), vbNullString)))
p = InStr(p + 1, tmp, Chr(40))
txt = Trim(Mid(tmp, p + 1, InStr(p + 1, tmp, Chr(41)) - (p + 1)))
If UBound(Filter(arr, txt, True)) < 0 Or dupes Then '<~~ check for duplicates within the array
a = a + 1
ReDim Preserve arr(1 To a)
arr(UBound(arr)) = txt
End If
Next b
If CBool(pos) Then
getBracketedText = arr(pos)
Else
getBracketedText = Join(arr, delim)
End If
End Function
Use like any other native worksheet function. There are optional parameters to retrieve an individual element or a collection as well as changing the default <comma><space> delimiter.
This code works for me:
Sub takingTheText()
Dim iniP 'first parenthesis
Dim endP 'last parentehis
Dim myText 'the text
Dim txtLen
Dim i
Dim tmp
Dim j
myText = Range("A1").Value
txtLen = Len(myText)
j = 0
Do 'Loop in the text
i = i + 1 'a counter
iniP = InStr(1, myText, "(", 1) 'found the first occurence of the (
endP = InStr(1, myText, ")", 1) 'same as above
tmp = tmp & Right(Left(myText, i), 1) 'take the text garbage text
If i = iniP Then 'here comes the work
j = j + 1 'here take the cell index
myText = Replace(myText, tmp, "") 'remove the garbage text in front the first (
tmp = Left(myText, endP - iniP - 1) 'reuse the var to store the usefull text
Cells(1, 2).Value = Cells(1, 2).Value & Chr(10) & tmp 'store in the cell B1
'If you want to stored in separated cells use the below code
'Cells(j, 2).Value = tmp
myText = Replace(myText, tmp & ")", "", 1, 1) ' remove the garbage text from the main text
tmp = Empty 'empty the var
i = 0 'reset the main counter
End If
Loop While endP <> 0
End Sub
Result:
Please check and tellme if is ok.
Edit#1
Cells(1, 2).Value = Cells(1, 2).Value & Chr(10) & tmp this code store the text in separated lines inside the same cell, may be you want to use spaces between the resulting text because of chr(10) (also you can use chr(13)), then you can use Cells(1, 2).Value = Cells(1, 2).Value & " " & tmp, or use any other character instead the string inside the & symbols
I am working on small project. I have encountered a problem that I am not able to bypass. Any help would be highly appreciated.
I have the following sheets:
Sheet1
Sheet2
I need a function that extracts those 3 figures from Sheet1 (there can be more or less than 3), they are always limited by "()" and look for values in Sheet2 based on figures in column A1.
I was able to write the following code (with help of this question) for extracting figures, but I do not know how to isolate figures from single cell and look based on it in sheet2:
Edit:
I thought I will manage with the rest, but I was wrong. I would appreciate additional help to expand the code to return column B from Sheet2. Generally, logic is that function splits cell from sheet1 and then each item is looked in Sheet2. The final result of this function would be:
Test1
Test2
Test3
I have updated the code with what I tried myself.
Function onlyDigits(s As String) As String
Dim retval As String
Dim i,j As Integer
Dim TestRng as Range
Dim NoArr() as String
Dim TestRes() as String
retval = ""
s = Replace(s, ")", " ")
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Or Mid(s, i, 1) = " " Then
retval = retval + Mid(s, i, 1)
End If
Next
'deletes last unnecessary space
retval = Left(retval, Len(retval) - 1)
'array with results after extracting numbers
NoArr() = Split(retval, " ", , vbTextCompare)
'vlookedup range
set TestRng = Worksheets("Sheet2").Range("A1:B3")
For j = LBound(NoArr) To UBound(NoArr)
TestRes(j) = Application.WorksheetFunction.VLookup(NoArr(j), TestRng, 2, 0)
Next j
onlyDigits = TestRes
End Function
Keeping with your current method, I modified your function to return the value you need by passing in a place holder. I modified the first and second to last lines.
Function onlyDigits(s As String, pos As Integer) As String
Dim retval As String
Dim i As Integer
retval = ""
s = Replace(s, ")", " ")
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Or Mid(s, i, 1) = " " Then
retval = retval + Mid(s, i, 1)
End If
Next
'deletes last unnecessary space
retval = Left(retval, Len(retval) - 1)
onlyDigits = Split(retval, " ", , vbTextCompare)(pos)
End Function
To call in cell write: =onlyDigits(A1,0) the zero is the position to return
Example
Column E shows the equation used in column D
ok I solved my problem with following code:
F Function onlyDigits(s As String) As String
Dim retval As String
Dim i, j As Integer
Dim TestRng As Range
Dim NoArr() As String
Dim TestRes() As String
retval = ""
s = Replace(s, ")", " ")
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Or Mid(s, i, 1) = " " Then
retval = retval + Mid(s, i, 1)
End If
Next
'deletes last unnecessary space
retval = Left(retval, Len(retval) - 1)
'array with results after extracting numbers
NoArr() = Split(retval, " ", , vbTextCompare)
'vlookedup range
Set TestRng = Worksheets("Sheet2").Range("A1:B3")
For j = LBound(NoArr) To UBound(NoArr)
ReDim Preserve TestRes(j)
TestRes(j) = Application.WorksheetFunction.VLookup(CLng(NoArr(j)), TestRng, 2, False)
Next j
onlyDigits = Join(TestRes, vbNewLine)
End Function
This might be a little tricky, even with VBA...
I have comma separated lists in cells based on start times over 5 minutes intervals but I need to remove times that are only 5 apart.
The numbers are text, not time at this point. For example, one list would be 2210, 2215, 2225, 2230, 2240 (the start times).
In this case, 2215 and 2230 should be removed but I also need to remove the opposite numbers (i.e.,2210 and 2225) in other cases (the end times).
Someone helped me with my specs:
A cell contains times: t(1), t(2), t(3), ... t(n). Starting at time t(1), each value in the list is examined. If t(x) is less than 6 minutes after t(x-1) delete t(x) and renumber t(x+1) to t(n).
Input:
2210, 2215, 2225, 2230, 2240
Output:
column1: 2210
column2: 2240
This does what I think you require.
Option Explicit
Sub DeleteSelectedTimes()
Dim RowCrnt As Long
RowCrnt = 2
Do While Cells(RowCrnt, 1).Value <> ""
Cells(RowCrnt, 1).Value = ProcessSingleCell(Cells(RowCrnt, 1).Value, 1)
Cells(RowCrnt, 2).Value = ProcessSingleCell(Cells(RowCrnt, 2).Value, -1)
RowCrnt = RowCrnt + 1
Loop
End Sub
Function ProcessSingleCell(ByVal CellValue As String, ByVal StepFactor As Long) As String
Dim CellList() As String
Dim CellListCrntStg As String
Dim CellListCrntNum As Long
Dim InxCrnt As Long
Dim InxEnd As Long
Dim InxStart As Long
Dim TimeCrnt As Long ' Time in minutes
Dim TimeLast As Long ' Time in minutes
CellList = Split(CellValue, ",")
If StepFactor = 1 Then
InxStart = LBound(CellList)
InxEnd = UBound(CellList)
Else
InxStart = UBound(CellList)
InxEnd = LBound(CellList)
End If
CellListCrntStg = Trim(CellList(InxStart))
If (Not IsNumeric(CellListCrntStg)) Or InStr(CellListCrntStg, ".") <> 0 Then
' Either this sub-value is not numeric or if contains a decimal point
' Either way it cannot be a time.
ProcessSingleCell = CellValue
Exit Function
End If
CellListCrntNum = Val(CellListCrntStg)
If CellListCrntNum < 0 Or CellListCrntNum > 2359 Then
' This value is not a time formatted as hhmm
ProcessSingleCell = CellValue
Exit Function
End If
TimeLast = 60 * (CellListCrntNum \ 100) + (CellListCrntNum Mod 100)
For InxCrnt = InxStart + StepFactor To InxEnd Step StepFactor
CellListCrntStg = Trim(CellList(InxCrnt))
If (Not IsNumeric(CellListCrntStg)) Or InStr(CellListCrntStg, ".") <> 0 Then
' Either this sub-value is not numeric or if contains a decimal point
' Either way it cannot be a time.
ProcessSingleCell = CellValue
Exit Function
End If
CellListCrntNum = Val(CellListCrntStg)
If CellListCrntNum < 0 Or CellListCrntNum > 2359 Then
' This value is not a time formatted as hhmm
ProcessSingleCell = CellValue
Exit Function
End If
TimeCrnt = 60 * (CellListCrntNum \ 100) + (CellListCrntNum Mod 100)
If Abs(TimeCrnt - TimeLast) < 6 Then
' Delete unwanted time from list
CellList(InxCrnt) = ""
Else
' Current time becomes Last time for next loop
TimeLast = TimeCrnt
End If
Next
CellValue = Join(CellList, ",")
If Left(CellValue, 1) = "," Then
CellValue = Mid(CellValue, 2)
CellValue = Trim(CellValue)
End If
Do While InStr(CellValue, ",,") <> 0
CellValue = Replace(CellValue, ",,", ",")
Loop
ProcessSingleCell = CellValue
End Function
Explanation
Sorry for the lack of instructions in the first version. I assumed this question was more about the technique for manipulating the data than about VBA.
DeleteSelectedTimes operates on the active worksheet. It would be easy to change to work on a specific worksheet or a range of worksheets if that is what you require.
DeleteSelectedTimes ignores the first row which I assume contains column headings. Certainly my test worksheet has headings in row 1. It then processes columns A and B of every row until it reaches a row with an empty column A.
ProcessSingleCell has two parameters: a string and a direction. DeleteSelectedTimes uses the direction so values in column A are processed left to right while values in column B are processed right to left.
I assume the #Value error is because ProcessSingleCell does not check that the string is of the format "number,number,number". I have changed ProcessSingleCell so if the string is not of this format, it does change the string.
I have no clear idea of what you do or do not know so come back with more questions as necessary.
Still not clear on your exact requirements, but this might help get you started....
Sub Tester()
Dim arr
Dim out As String, x As Integer, c As Range
Dim n1 As Long, n2 As Long
For Each c In ActiveSheet.Range("A1:A10")
If InStr(c.Value, ",") > 0 Then
arr = Split(c.Value, ",")
x = LBound(arr)
out = ""
Do
n1 = CLng(Trim(arr(x)))
n2 = CLng(Trim(arr(x + 1)))
'here's where your requirements get unclear...
out = out & IIf(Len(out) > 0, ", ", "")
If n2 - n1 <= 5 Then
out = out & n1 'skip second number
x = x + 2
Else
out = out & n1 & ", " & n2 'both
x = x + 1
End If
Loop While x <= UBound(arr) - 1
'pick up any last number
If x = UBound(arr) Then
out = out & IIf(Len(out) > 0, ", ", "") & arr(x)
End If
c.Offset(0, 1).Value = out
End If
Next c
End Sub
Obviously many ways to skin this cat ... I like to use collections for this sort of thing:
Private Sub PareDownList()
Dim sList As String: sList = ActiveCell ' take list from active cell
Dim vList As Variant: vList = Split(sList, ",") ' convert to variant array
' load from var array into collection
Dim cList As New Collection
Dim i As Long
For i = 0 To UBound(vList): cList.Add (Trim(vList(i))): Next
' loop over collection removing unwanted entries
' (in reverse order, since we're removing items)
For i = cList.Count To 2 Step -1
If cList(i) - cList(i - 1) = 5 Then cList.Remove (i)
Next i
' loop to put remaining items back into a string fld
sList = cList(1)
For i = 2 To cList.Count
sList = sList + "," + cList(i)
Next i
' write the new string to the cell under the activecell
ActiveCell.Offset(1) = "'" + sList ' lead quote to ensure output cell = str type
End Sub
' If activecell contains: "2210, 2215, 2225, 2230, 2240"
' the cell below will get: "2210,2225,2240"
Note: this sample code should be enhanced w some extra validation & checking (e.g. as written assumes all good int values sep by commas & relies in implicit str to int conversions). Also as written will convert "2210, 2215, 2220, 2225, 2230, 2240" into "2210, 2040" - you'll need to tweak the loop, loop ctr when removing an item if that's not what you want.