I have a set of descriptions that contain ID numbers arranged into a column. For example:
Column A
This is a description with the ID number in it ID12345.
This is a description ID66666 with the ID number in it.
This is ID99999 a description with the ID number in it.
The Id numbers are always in the format "IDXXXXX" I'd like to somehow trim away all the text in each of these cells and leave just that ID number.
My thoughts:
Can this be somehow done by finding a string like "ID?????" and setting that to a variable, then replacing the contents of the cell with that variable? Or by erasing all characters in a cell -except- for "ID?????"
Any help would be appreciated, thanks.
This code I wrote for you will iterate through all items in Column A. It will split all the words in each cell into an array. If the word is 7 or 8 characters long then it could potentially be an IDxxxxx. It will perform a few checks to see if it really matches an IDxxxxx syntax. In case it does it will replace the contents of the cell with just the ID dropping all the remaining text.
Sub ReplaceContentWithIDs()
Dim ws As Worksheet
Set ws = Sheets("Sheet1") ' or your sheet name
Dim rng As Range
Dim i&, lr&, j&
Dim arr
Dim str$
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
' starting from 1 - if you have headers change to 2
For i = 1 To lr
Set rng = ws.Range("A" & i)
arr = Split(CStr(rng.Value), " ")
For j = LBound(arr) To UBound(arr)
str = arr(j)
If (Len(str) = 7) Or (Len(str) = 8) Then
If (StrComp(Left(str, 2), "ID", vbTextCompare) = 0) And _
IsNumeric(Right(Left(str, 7), 5)) Then
' found it
If Len(str) = 8 Then
rng.Value = Left(str, 7)
ElseIf Len(str) = 7 Then
rng.Value = str
End If
End If
End If
Next j
Set rng = Nothing
Next i
End Sub
I took this as a challenge to my intellect, and given that it is the end of the day, after seeing the formulas by Aladdin and pgc01 on Mr Excel forums I did a little work and came up with this CSE (Array formula):
=IF(ISNUMBER(LOOKUP(9.99999999999999E+307,SEARCH({"ID0","ID2","ID3","ID4","ID5","ID6","ID7","ID8","ID9"},A1))),MID(A1,LOOKUP(9.99999999999999E+307,SEARCH({"ID0","ID2","ID3","ID4","ID5","ID6","ID7","ID8","ID9"},A1)),7),"")
I also had some luck with this CSE Array formula:
=IF(ISNUMBER(SEARCH("ID"&{1,2,3,4,5,6,7,8,9},$A$1)),MID(A$1,SEARCH("ID"&{1,2,3,4,5,6,7,8,9},$A$1),7))
Related
Background info:
I have a listing of 5000+ error messages in this format:
"999999 16 901 F SMITH, Smith FT 1 1.0 Additional Leave hours -4.0000 exceed entitlement plus pro-rata -4.0000"
I have been able to categorise them using a macro, so "Additional Leave hours exceed entitlement plus pro-rata" for example.
From there I'm trying to extract the two numbers.
I can do it manually using these formulas:
=MID(J3,SEARCH("hours ",J3)+5,SEARCH("exceed",J3)-SEARCH("hours ",J3)-6)
=TRIM(RIGHT(SUBSTITUTE(J3," ",REPT(" ",LEN(J3))),LEN((J3))))
But this is where i'm stuck, incorporating that logic in the macro and having it loop through the full list.
This was my first attempt:
If InStr(myString, "Additional Leave hours ") > 0 And InStr(myString, "exceed entitlement plus pro-rata") Then
'set category
Cells(x, 6).Value = "Additional Leave hours exceed entitlement plus pro-rata"
'first number
Cells(x, 8).ForumlaR1C1 = "=MID(RC[2],SEARCH(""hours "",RC[2])+5,SEARCH(""exceed"",RC[2])-SEARCH(""hours "",RC[2])-6"
'second number
Cells(x, 9).FormulaR1C1 = "=TRIM(RIGHT(SUBSTITUTE(RC[2],"" "",REPT("" "",LEN(RC[2]))),LEN((RC[2]))))"
'first minus second
Cells(x, 7).FormulaR1C1 = "=SUM(RC[2]-RC[1]"
End If
From there I have been able to use .Select & .Active cell, and it works but not efficiently:
'first number
Cells(x, 8).Select
ActiveCell.FormulaR1C1 = "=MID(RC[2],SEARCH(""hours"",RC[2])+5,SEARCH(""exceed"",RC[2])SEARCH(""hours "",RC[2])-6)"
Any help would be appreciated, thanks in advance.
Idea is to process all the strings in an array (so that it's faster, compared to writing/reading cells 1 by 1), use RegExp to extract the 2 numbers into an array which will be used to paste into the previous 2 columns. Finally insert the SUM formula into the column before:
Sub Test()
Const inputStartRow As Long = 1
Const inputCol As String = "J"
Const regexPattern As String = "Additional Leave hours ([-\d.]{1,}) exceed entitlement plus pro-rata ([-\d.]{1,})"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change name accordingly
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Pattern = regexPattern
.Global = False
End With
'==== Get last row of the input column and set to range
Dim inputLastRow As Long
inputLastRow = ws.Cells(ws.Rows.Count, inputCol).End(xlUp).Row
Dim inputRng As Range
Set inputRng = ws.Range(ws.Cells(inputStartRow, inputCol), ws.Cells(inputLastRow, inputCol))
'==== Populate the array with the input range's value
Dim inputArr As Variant
inputArr = inputRng.Value
Dim outputArr() As String
ReDim outputArr(1 To UBound(inputArr, 1), 1 To 2) As String
'==== Loop through the array and extract the 2 numbers
Dim i As Long
For i = 1 To UBound(inputArr, 1)
If InStr(inputArr(i, 1), "Additional Leave hours ") > 0 And InStr(inputArr(i, 1), "exceed entitlement plus pro-rata") Then
If regex.Test(inputArr(i, 1)) Then
Dim regexMatch As Object
Set regexMatch = regex.Execute(inputArr(i, 1))(0)
outputArr(i, 1) = regexMatch.SubMatches(0)
outputArr(i, 2) = regexMatch.SubMatches(1)
End If
End If
Next i
'==== Insert the extraction # Input column - 1/ -2
Dim outputRng As Range
Set outputRng = inputRng.Offset(, -2).Resize(, 2)
outputRng.Value = outputArr
Set outputRng = Nothing
'==== Add in SUM formula # Input Column - 3
Dim sumRng As Range
Set sumRng = inputRng.Offset(, -3)
sumRng.Formula = "=SUM(" & ws.Cells(inputStartRow, sumRng.Column + 1).Address(RowAbsolute:=False) & "-" & ws.Cells(inputStartRow, sumRng.Column + 2).Address(RowAbsolute:=False) & ")"
Set sumRng = Nothing
End Sub
Alright, this is a very specific question. I have an excel macro written that takes a web URL, delimits it, transposes it, and then adds adjacent columns that describe the information in the originally transposed columns. Now, I need to add something to my macro that will loop through and check if the first character of one cell matches one of the first 4 characters of another cell. If it does, I need to concatenate strings from the descriptive columns to new cells. I'll illustrate this below:
3,435,201,0.5,%22type%25202%2520diabetes%22,0 Node type 2 diabetes
4,165,97,0.5,%22diet%22,0 Node diet
5,149,248,0.5,%22lack%2520of%2520exercise%22,2 Node lack of exercise
6,289,329,0.5,%22genetics%22,3 Node genetics
7,300,71,0.5,%22blood%2520pressure%2520%22,5 Node blood pressure
7,3,-7,1,0 Arrow +
4,3,-21,1,0 Arrow +
5,3,-22,1,0 Arrow +
6,3,-34,1,0 Arrow +
,7%5D Tail
I added color to make the concept of the problem more easily visualized. In row one of the first column, we see a red 3 that corresponds to 'type 2 diabetes'. In the fifth row of the first column, we see a blue 7 that corresponds to 'blood pressure'. These are both node objects, as the adjacent column signifies. In the sixth cell of the first column we see a blue 7 and a red 3. This indicates that an arrow (also signified by adjacent column) is connecting blood pressure to diabetes. In the next column over, we see an orange plus sign, which indicates this is a positive relationship.
The goal is to populate the next column over with "blood pressure + type diabetes", as I demonstrated in the image. So, I need some code to check the first characters in each node cell, and then compare them to the first 4 characters of each arrow cell. When an arrow that matches two of the nodes is found, I need the code to populate the row next to the + signs with a concatenated string comprised of the names of the nodes pertaining to that arrow, as well as the + sign between them (it's possible that it could also be a minus sign, but one isn't present in this example). Any pointers? I can't wrap my head around this. Edited to add Data
Here is the code of my current macro:
Sub Delimit_Transpose()
Cells.Replace What:="],[", Replacement:="#", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,LEN(R[-1]C)-36)"
Dim i As Long, strTxt As String
Dim startP As Range
Dim xRg As Range, yRg As Range
On Error Resume Next
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Delimit Transpose", Type:=8)
i = 1
Application.ScreenUpdating = False
For Each yRg In xRg
If i = 1 Then
strTxt = yRg.Text
i = 2
Else
strTxt = strTxt & "," & yRg.Text
End If
Next
Application.ScreenUpdating = True
Set startP = Application.InputBox _
(Prompt:="Paste Range...", _
Title:="Delimit Transpose", Type:=8)
ary = Split(strTxt, "#")
i = 1
Application.ScreenUpdating = False
For Each a In ary
startP(i, 1).Value = Replace(Replace(a, "[", ""), "]", "")
i = i + 1
Next a
i = 1
For Each a In ary
If Len(a) > 13 Then
startP.Offset(i - 1, 1).Value = "Node"
ElseIf Len(a) < 13 And Len(a) > 6 Then
startP.Offset(i - 1, 1).Value = "Arrow"
Else
startP.Offset(i - 1, 1).Value = "Tail"
End If
i = i + 1
Next a
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
i = 1
n = 5
For Each a In ary
openPos = InStr(a, ",%22")
On Error Resume Next
closePos = InStr(a, "%22,")
On Error Resume Next
midBit = Mid(a, openPos + 1, closePos - openPos - 1)
On Error Resume Next
If openPos <> 0 And Len(midBit) > 0 Then
startP.Offset(i - 1, 2).Value = Replace(Replace(midBit, "%22", ""), "%2520", " ")
ElseIf Len(a) < 13 And InStr(a, "-") = 4 Then
startP.Offset(i - 1, 2).Value = "'-"
ElseIf Len(a) < 7 Then
startP.Offset(i - 1, 2).Value = " "
Else
startP.Offset(i - 1, 2).Value = "+"
End If
i = i + 1
n = n + 1
Next a
Application.ScreenUpdating = True
End Sub
This is my approach.
There's room for a lot of improvements, but is a rough code that should get you started.
Read the code's comments and adapt it to fit your needs.
EDIT: I updated the code to match the sample worksheet you uploaded, build the first column range dinamically, validate if commas appear in the first column cell so no error is raised.
As I said in the comments, it's better easier to debug if you call one procedure from the other, instead of merging them.
Code:
Option Explicit
Public Sub StoreConcatenate()
' Basic error handling
On Error GoTo CleanFail
' Define general parameters
Dim targetSheetName As String
targetSheetName = "Test space" ' Sheet holding the data
Dim firstColumnLetter As String
firstColumnLetter = "C" ' First column holding the numbers
Dim firstColumnStartRow As Long
firstColumnStartRow = 7
' With these three parameters we'll build the range address holding the first column dynamically
' Set reference to worksheet
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
' Find last row in column (Modify on what column)
Dim firstColumnlastRow As Long
firstColumnlastRow = targetSheet.Cells(targetSheet.Rows.Count, firstColumnLetter).End(xlUp).Row
' Build range of first column dinamically
Dim firstColumnRange As Range
Set firstColumnRange = targetSheet.Range(firstColumnLetter & firstColumnStartRow & ":" & firstColumnLetter & firstColumnlastRow)
' Loop through first column range cells
Dim valueCell As Range
For Each valueCell In firstColumnRange
' Check if cell contains "," in the second position in string
If InStr(valueCell.Value, ",") = 2 Then
' Store first digit of cell before ","
Dim firstDigit As Integer
firstDigit = Split(valueCell.Value, ",")(0)
' Check if cell contains "," in the fourth position in string
If InStr(3, valueCell.Value, ",") = 4 Then
' Store second digit of cell after ","
Dim secondDigit As Integer
secondDigit = Split(valueCell.Value, ",")(1)
End If
' Store second colum type
Dim secondColumnType As String
secondColumnType = valueCell.Offset(, 1).Value
' Store third column value
Dim thirdColumnValue As String
thirdColumnValue = valueCell.Offset(, 2).Value
' Store nodes values (first digit and second column type)
Select Case secondColumnType
Case "Node"
Dim nodeValues() As Variant
Dim nodeCounter As Long
ReDim Preserve nodeValues(nodeCounter)
nodeValues(nodeCounter) = Array(firstDigit, thirdColumnValue)
nodeCounter = nodeCounter + 1
Case "Arrow"
Dim matchedNodeFirstValue As String
Dim matchedNodeSecondValue As String
matchedNodeFirstValue = IsInArrayReturnItem(firstDigit, nodeValues)(1)
matchedNodeSecondValue = IsInArrayReturnItem(secondDigit, nodeValues)(1)
If matchedNodeFirstValue <> vbNullString And matchedNodeSecondValue <> vbNullString Then
valueCell.Offset(, 3).Value = matchedNodeFirstValue & Space(1) & thirdColumnValue & Space(1) & matchedNodeSecondValue
End If
End Select
End If
Next valueCell
CleanExit:
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
' Credits: https://stackoverflow.com/a/38268261/1521579
Public Function IsInArrayReturnItem(stringToBeFound As Integer, arr As Variant) As Variant
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i)(0) = stringToBeFound Then
IsInArrayReturnItem = arr(i)
Exit Function
End If
Next i
IsInArrayReturnItem = Array(vbNullString, vbNullString)
End Function
Let me know if it works
It appears that you are concatenating the lookups based on the
first and second integers,
where the second column = "Arrow"
If that is the case, I suggest:
Read the data table into a VBA array for faster processing
I am assuming your data is ordered as you show it, with all the Node entries at the start.
if that is not the case, then loop twice -- once to find the Nodes, and second time to concatenate the Arrow data.
Read the diagnoses into a dictionary for fact lookup.
if column2 = "Arrow" then concatenate the lookups of the first and second integers
Write back the data
Note: As written, this will overwrite the original table destroying any formulas that might be there. If needed, you could easily modify it to only overwrite the necessary area.
Note2 Be sure to set a reference (under Tools/References) to Microsoft Scripting Runtime, or change the Dictionary declaration to late-binding.
Regular Module
'set reference to Microsoft Scripting Runtime
Option Explicit
Sub Dx()
Dim WS As Worksheet
Dim rngData As Range, c As Range, vData As Variant
Dim dDx As Dictionary
Dim I As Long, sKey As String, dxKeys As Variant
'Get the data range
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS
'assume table starts in A1 and is three columns wide
Set rngData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
'read into variant array for faster processing
vData = rngData
End With
'create dictionsry for dx lookups
Set dDx = New Dictionary
For I = 2 To UBound(vData, 1)
Select Case vData(I, 2)
Case "Node"
sKey = Split(vData(I, 1), ",")(0) 'first comma-separated number
If dDx.Exists(sKey) Then
MsgBox "duplicate diagnostic key. Please correct the data"
Exit Sub
End If
dDx.Add Key:=sKey, Item:=vData(I, 3)
Case "Arrow"
dxKeys = Split(vData(I, 1), ",")
vData(I, 3) = dDx(dxKeys(0)) & " + " & dDx(dxKeys(1))
End Select
Next I
'reWrite the table
Application.ScreenUpdating = False
rngData = vData
End Sub
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