Assume to have the following Excel table
I'm trying to write a Macro in VBA which scans the cells in the routing column and spreads the substrings into the other columns. So this should be the final result
Potentially if the algorithm finds n substrings in the main string under the column Rtg it should fill n columns with the substrings.
Can you guys help me?
Thanks in advance
We can parse using the dash character:
Sub dural()
Dim i As Long, N As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To N
arr = Split(Cells(i, 2).Value, "-")
Cells(i, 2).Offset(0, 1).Resize(1, UBound(arr) + 1) = arr
Next i
End Sub
EDIT#1:
The code will err if it encounters an empty cell prematurely. To avoid this use:
Sub dural()
Dim i As Long, N As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To N
v = Cells(i, 2).Value
If v <> "" Then
arr = Split(v, "-")
Cells(i, 3).Resize(1, UBound(arr) + 1) = arr
End If
Next i
End Sub
As outlined here, you can use Text to Columns:
Select the cell or column that contains the text you want to split.
Select Data > Text to Columns.
In the Convert Text to Columns Wizard, select Delimited > Next.
Select the Delimiters for your data. You'd want to put a - in the "Other" area.
Select Next.
Select the Column data format or use what Excel chose for you.
Select the Destination, which is where you want the split data to
appear on your worksheet.
Select Finish.
Here is a simple sub for operating on the current active cell.
Sub splitCell()
Dim cellSplit As Variant
Dim nextColumn As Long
nextColumn = 1
cellSplit = Split(ActiveCell.Value2, "-")
For Each Item In cellSplit
ActiveCell.Offset(0, nextColumn).Value2 = Item
nextColumn = nextColumn + 1
Next
End Sub
None of the other solutions appear to deal with leading hyphens correctly.
This should deal with leading/trailing/double hyphens on the currently selected cells within one column. The caveat is that the individual substrings should not contain spaces.
Sub splitHyphens()
Dim i As Long, sel As Range, vals As Variant
For Each sel In Selection
vals = Split(Application.Trim(Replace(sel.Value, "-", Space(1))), Space(1))
sel.Offset(0, 1).Resize(1, UBound(vals) + 1) = vals
Next sel
End Sub
Related
I am using below mentioned formula to filter out the unwanted text from a Cell. I would like to use this formula via VBA, i have tried some method that includes Sub Formula_Property and Recording Macro but not successful.
The formula is mentioned below:
=LEFT(A3,MIN(FIND({1,2,3,4,5,6,7,8,9,0},A3 & "1234567890"))-1)
The Main data is available in Sheet1 ColumnA2:A5000 and I would like the filtered text (Result) in Sheet3 column B2:B5000.
Is there anyway i can automate this using VBA, that would be helpful for me much.
Thank you
Parse Left of First Digit
Sub ParseLeftOfDigit()
Dim Data(): Data = Sheet1.Range("A2:A5000").Value
Dim r As Long, n As Long, rStr As String
For r = 1 To UBound(Data, 1)
rStr = CStr(Data(r, 1))
For n = 1 To Len(rStr)
If Mid(rStr, n, 1) Like "#" Then
Data(r, 1) = Mid(rStr, 1, n - 1)
Exit For
End If
Next n
Next r
Sheet3.Range("B2:B5000").Value = Data
End Sub
This macro will apply that formula to the range you wish.
Sub Filter_Text_Formula()
Sheets("Sheet3").Range("B2:B5000").FormulaR1C1 = "=LEFT(Sheet1!RC[-1],MIN(FIND({1,2,3,4,5,6,7,8,9,0},Sheet1!RC[-1] & ""1234567890""))-1)"
End Sub
I have a workbook with cells that have linebreaks (entered via ALT + ENTER).
I have to separate them into individual rows. All the cells are in column A.
Each line in the cell has a bullet point (eg. "* ") up front, which could serve as a beacon to break the line at this point.
You can use split with Chr(10) or VbLf
Dim cell_value As Variant
Dim counter As Integer
'Row counter
counter = 1
'Looping trough A column define max value
For i = 1 To 10
'Take cell at the time
cell_value = ThisWorkbook.ActiveSheet.Cells(i, 1).Value
'Split cell contents
Dim WrdArray() As String
WrdArray() = Split(cell_value, vbLf)
'Place values to the B column
For Each Item In WrdArray
ThisWorkbook.ActiveSheet.Cells(counter, 2).Value = Item
counter = counter + 1
Next Item
Next i
No you have array to place each row to different cell
There is no need of code for this, lets make it simple.
Follow the bellow steps.
Select the data-set you want to split -> Go to Data Tab -> Select "Text to columns" -> from this pop-up select "Delimited" -> Select which delimiter is separating your texts -> Select the destination cell -> Click "OK"
Try This.
Regards,
Ashwin
Edit from Markus: For the newline as delimiter use "Ctr-J"
If you select the cell and run the macro you would get what you want on the next column like this:
Option Explicit
Public Sub selection_into_rows()
Dim k As Variant
Dim l_counter As Long
k = Split(Selection, Chr(10))
For l_counter = LBound(k) To UBound(k)
Cells(l_counter + 1, Selection.Column + 1) = k(l_counter)
Next l_counter
End Sub
This will work on one row only after selecting it (but should get you started):
Option Explicit
Public Sub SelectionIntoRows()
Dim k() As String
Dim l As Long
Dim i As Long
k() = Split(Range("A1"), " ")
i = 1
For l = 0 To UBound(k)
Cells(i, 1) = k(l)
i = i + 1
Next l
End Sub
Sub extract()
'Query extract data in cell B divided by ALT+Enter, Comma space
'Mandatory to create in front Sheet1, Sheet2, and Sheet3
'ATTENTION! if field B is empty return no data!! Manually add column A (with empty column B)if needed!!
'manually remove empty cell in results (Sheet2)
'before START Query remove duplicate from input data!!
'Doesn't work with full stop
'When finished Msg Done will be display
Dim c As Long, r As Range, I As Long, d As Long, Temp() As String
d = 0
For Each r In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row) ' Change this to suit your range..
c = 2
Temp = Split((r.Value), Chr(10))
For i = LBound(Temp) To UBound(Temp)
Sheets("Sheet2").Cells(r.Row, c - 1).Offset(d, 0).Value = Cells(r.Row, r.Column - 1).Value
Sheets("Sheet2").Cells(r.Row, c).Offset(d, 0).Value = Temp(i)
Cells(r.Row, c).Offset(d, 0).Select
ActiveCell.Value = Trim(ActiveCell.Value)
d = d + 1
Next
d = d - 1
Next
Sheets("Sheet2").Select
Columns("A:B").Select
ActiveSheet.Range("$A$1:$B$62856").RemoveDuplicates Columns:=Array(1, 2), _
Header:=xlYes
Range("A1").Select
I had a half dozen of these blobs from an poor Acrobat PDF to XLSX conversion, peppered throughout 500 rows.
I copied the text blob (like OP) into Notepad, removed "" from the start and end line, and pasted to a new spreadsheet. That tells me how many lines to insert. Then pasted into that hole.
"This was all of
my input text"
Then I could use TextToCol.
I need to find all instances of particular identifier that may occur in one column and concatenate them into one string.
The identifier will start with "ECP" and be separated by a dash or space and have several characters after the separator. E.g. "ECP 05-00012A1, "ECP-123456."
I was using the formula below, but didn't think of multiple "ECP numbers."
=INDEX('Raw WAM Data'!$A$1:$A$10000,MATCH(VLOOKUP("*"&"ECP"&"*",'Raw WAM Data'!$A$1:$A$10000,1,FALSE),'Raw WAM Data'!$A$1:$A$10000,0))
I was then parsing the data in an adjacent cell using: =LEFT($C$62,FIND(" ", $C$62, FIND(" ", $C$62)+1))
This string was then loaded into a UserForm TextBox.
I would then need concatenate all the returned values into one string separated by commas so that it can load into the UserForm TextBox.
I would think that VBA would be ideal for this, but I am open to any suggestions.
If I've got correct understanding of what you trying to achive then you can use something like this:
Sub TEST()
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim cl As Range, x&
With Sheets("Sheet1") 'replace sheet1 by name of your sheet
x = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cl In .Range(.[A1], .Cells(x, "A"))
If UCase(cl.Value2) Like "ECP*" And Not dic.exists(cl.Value2) Then
dic.Add cl.Value2, Nothing
End If
Next cl
End With
Debug.Print Join(dic.keys, Chr(10))
End Sub
test
Updated
What's the best way to put the results in Column E relative to the cell in which it was found? Also, if I wanted to search multiple columns, how should I adapt the code?
you can use this way:
Sub TEST2()
Dim cl As Range, x&
With Sheets("Sheet1") 'replace sheet1 by name of your sheet
x = .[A:C].Find("*", , , , xlByRows, xlPrevious).Row 'get the last used row in range
For Each cl In .Range(.[A1], .Cells(x, "C"))
If UCase(cl.Value2) Like "*ECP*" Then
If .Cells(cl.Row, "E").Value2 = "" Then
.Cells(cl.Row, "E").Value2 = cl.Value2
Else
.Cells(cl.Row, "E").Value2 = .Cells(cl.Row, "E").Value2 & "; " & cl.Value2
End If
End If
Next cl
End With
End Sub
Output
If your values are in column A of a worksheet this routine will gather your ECP numbers and load them into an array. You can then load the array into your TextBox.
Sub GatherECPs()
Dim ECParr
'Loop down each row starting at row 2 (assuming you have headers)
For x = 2 To SourceSheet.Range("A2").End(xlDown).Row
'Check if the start of the string is ECP
If Left(SourceSheet.Cells(x, 1).Value, 3) = "ECP" Then
'Add a row to the array
If IsEmpty(ECParr) Then
ReDim ECParr(0)
Else
ReDim Preserve ECParr(UBound(ECParr) + 1)
End If
'Add the value to the array
ECParr(UBound(ECParr)) = Right(SourceSheet.Cells(x, 1).Value, Len(SourceSheet.Cells(x, 1).Value) - 4)
End If
Next
End Sub
Replace SourceSheet with the sheet where your values exist.
To do it in a fast way which also works for multiple "ECP" in one cell just use this function:
Public Function getStr(rng As Range, ident As String) As String
Dim i As Long, x As Variant, y As Variant
For Each x In Intersect(rng, rng.Parent.UsedRange).Value
y = Split(x, ident)
If UBound(y) > 0 Then
For i = 1 To UBound(y)
getStr = getStr & ", " & ident & Split(y(i), ",")(0)
Next
End If
Next
getStr = Mid(getStr, 3)
End Function
It will return a comma separated string. just use it like: getStr(Range("A:A"), "ECP")
If you still have any questions, just ask ;)
I need to find a way to split some data on excel: e.g.
If a cell has the following in: LWPO0001653/1654/1742/1876/241
All of the info after the / should be LWPO000... with that number.
Is there anyway of separating them out and adding in the LWPO000in? So they come out as LWPO0001653
LWPO0001654
etc etc
I could do manually yes, but i have thousands to do so would take a long time.
Appreciate your help!
Here is a solution using Excel Formulas.
With your original string in A1, and assuming the first seven characters are the one's that get repeated, then:
B1: =LEFT($A1,FIND("/",$A1)-1)
C1: =IF(LEN($A1)-LEN(SUBSTITUTE($A1,"/",""))< COLUMNS($A:A),"",LEFT($A1,7)&TRIM(MID(SUBSTITUTE(MID($A1,8,99),"/",REPT(" ",99)),(COLUMNS($A:A))*99,99)))
Select C1 and fill right as far as required. Then Fill down from Row 1
EDIT: For a VBA solution, try this code. It assumes the source data is in column A, and puts the results adjacent starting in Column B (easily changed if necessary). It works using arrays within VBA, as doing multiple worksheet read/writes can slow things down. It will handle different numbers of splits in the various cells, although could be shortened if we knew the number of splits was always the same.
Option Explicit
Sub SplitSlash()
Dim vSrc As Variant
Dim rRes As Range, vRes() As Variant
Dim sFirst7 As String
Dim V As Variant
Dim COL As Collection
Dim I As Long, J As Long
Dim lMaxColCount As Long
Set rRes = Range("B1") 'Set to A1 to overwrite
vSrc = Range("a1", Cells(Rows.Count, "A").End(xlUp))
'If only a single cell, vSrc won't be an array, so change it
If Not IsArray(vSrc) Then
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = Range("a1")
End If
'use collection since number of columns can vary
Set COL = New Collection
For I = 1 To UBound(vSrc)
sFirst7 = Left(vSrc(I, 1), 7)
V = Split(vSrc(I, 1), "/")
For J = 1 To UBound(V)
V(J) = sFirst7 & V(J)
Next J
lMaxColCount = IIf(lMaxColCount < UBound(V), UBound(V), lMaxColCount)
COL.Add V
Next I
'Results array
ReDim vRes(1 To COL.Count, 1 To lMaxColCount + 1)
For I = 1 To UBound(vRes, 1)
For J = 0 To UBound(COL(I))
vRes(I, J + 1) = COL(I)(J)
Next J
Next I
'Write results to sheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
I'm clearly missing the point :-) but anyway, in B1 and copied down to suit:
=SUBSTITUTE(A1,"/","/"&LEFT(A1,7))
Select ColumnB, Copy and Paste Special, Values over the top.
Apply Text to Columns to ColumnB, Delimited, with / as the delimiter.
There's a couple of ways to solve this. The quickest is probably:
Assuming that the data is in column A:
Highlight the column, go to Data>>Text To Columns
Choose "Delimited" and in the "Other" box, put /
Click ok. You'll have your data split into multiple cells
Insert a column at B and put in the formula =Left(A1, 7)
Insert a column at C and pit in formula =Right(A1, Length(A1)-7)
You'll now have Column B with your first 7 characters, and columns B,C,D,E,F, etc.. with the last little bit. You can concatenate the values back together for each column you have with =Concatenate(B1,C1), =Concatenate(B1,D1), etc..
A quick VBa, which does nearly the same thing that #Kevin's does as well. I wrote it before I saw his answer, and I hate to throw away work ;)
Sub breakUpCell()
Dim rngInput As Range, rngInputCell As Range
Dim intColumn As Integer
Dim arrInput() As String
Dim strStart As String
Dim strEnd As Variant
'Set the range for the list of values (Assuming Sheet1 and A1 is the start)
Set rngInput = Sheet1.Range("A1").Resize(Sheet1.Range("A1").End(xlDown).Row)
'Loop through each cell in the range
For Each rngInputCell In rngInput
'Split up the values after the first 7 characters using "/" as the delimiter
arrInput = Split(Right(rngInputCell.Value, Len(rngInputCell.Value) - 7), "/")
'grab the first 7 characters
strStart = Left(rngInputCell.Value, 7)
'We'll be writing out the values starting in column 2 (B)
intColumn = 2
'Loop through each split up value and assign to strEnd
For Each strEnd In arrInput
'Write the concatenated value out starting at column B in the same row as rngInputCell
Sheet1.Cells(rngInputCell.Row, intColumn).Value = strStart & strEnd
'Head to the next column (C, then D, then E, etc)
intColumn = intColumn + 1
Next strEnd
Next rngInputCell
End Sub
Here is how you can do it with a macro:
This is what is happening:
1) Set range to process
2) Loop through each cell in range and check it isn't blank
3) If the cell contains the slash character then split it and process
4) Skip the first record and concatenate "LWPO000" plus the current string to adjacent cells.
Sub CreateLWPO()
On Error Resume Next
Application.ScreenUpdating = False
Dim theRange
Dim cellValue
Dim offset As Integer
Dim fields
'set the range of cells to be processed here
Set theRange = range("A1:A50")
'loop through each cell and if not blank process
For Each c In theRange
offset = 0 'this will be used to offset each item found 1 cell to the right (change this number to this first column to be populated)
If c.Value <> "" Then
cellValue = c.Value
If InStr(cellValue, "/") > 0 Then
fields = Split(cellValue, "/")
For i = 1 To UBound(fields)
offset = offset + 1
cellValue = "LWPO000" & fields(i)
'if you need to pad the number of zeros based on length do this and comment the line above
'cellValue = "LWPO" & Right$(String(7, "0") & fields(i), 7)
c.offset(0, offset).Value = cellValue
Next i
End If
End If
Next
Application.ScreenUpdating = True
End Sub
I have an Excel table in which sometimes an entire cell has the following content:
pos=51;70;112;111;132;153
Note the whole content in in a single cell, that is to say the value 51;70;112... are strings clumped together in a single cell and not in their own cells.
Can I write a macro that in all cells that contain the keyphrase "pos=", add 2 to each value, so that the end result is:
pos=53;72;114;113;134;155
Here is a code that will do it (tested on a sample on my Excel 2003):
Sub t()
Dim rCells As Range, c As Range
Dim arr As Variant, i As Integer
'Define the range to apply the code
Set rCells = Range("A1")
For Each c In rCells
'check if the cell desserves to be changed (could be adapted though to another check)
If Left(c.Value, 4) = "pos=" Then
'split all the values after the "pos=" into an array
arr = Split(Mid(c.Value, 5, Len(c.Value)), ";")
'add +2 to every value of the array (we convert the value to be sure, probably unneeded)
For i = 0 To UBound(arr)
arr(i) = CLng(arr(i)) + 2
Next i
'set back the value to the worksheet
c.Value = "pos=" & Join(arr, ";")
End If
Next c
End Sub
Note that I didn't add the error checking part if your values aren't well formated.
You know that you can easily split data without using macros, right? Just use the TextToColumns function on the Data tab
But if you really want a macro, you can do something like the following:
Sub AddNumber()
Dim numberToAdd As Integer
numberToAdd = 2
Set myRange = Range("A1:A5")
For Each myCell In myRange
If Left(myCell.Value, 4) = "pos=" Then
arEquality = Split(myCell, "=")
arElements = Split(arEquality(1), ";")
For i = 0 To UBound(arElements)
arElements(i) = arElements(i) + numberToAdd
Next
myCell.Offset(0, 1).Value = arEquality(0) + "=" + Join(arElements, ";")
End If
Next
End Sub