Excel VBA parse column, extract all substrings - excel

I'm trying to parse a column that contains data in the following format in each cell -
pull: test1
or
pull: test2|pull: test3|.....
or
other: blah...
I only want a grab each "Pull: test" and place 1 in each row in a new worksheet like below, and ignore any parts of the cell that don't begin with "pull: " -
pull: test1
pull: test2
pull: test3
...
What I have so far just pulls the entire column and pastes into the same spreadsheet, I'm not sure how to separate the items in each cell into their own rows. I also can't get it to pull to a different worksheet correctly either (commented out my attempt)
Sub InStrDemo()
Dim lastrow As Long
Dim i As Integer, icount As Integer
'Sheets.Add.Name = "TEST"
lastrow = ActiveSheet.Range("A10000").End(xlUp).Row
For i = 1 To lastrow
If InStr(1, LCase(Range("E" & i)), "pull:") <> 0 Then
icount = icount + 1
'Sheets("TEST").Range("A" & icount & ":E" & icount) = Worksheets("SearchResults").Range("A" & i & ":E" & i).Value
Range("L" & icount) = Range("E" & i).Value
End If
Next i
End Sub

Untested, written on mobile.
Option Explicit
Sub testDemo()
Dim sourceSheet as worksheet
Set sourceSheet = ActiveSheet ' would be more reliable to qualify the workbook and worksheet by name'
Dim outputSheet as worksheet
Set outputSheet = thisworkbook.worksheets.add
Dim lastRow As Long
lastrow = sourceSheet.Range("A10000").End(xlUp).Row
' I assume column E needs to be parsed'
Dim arrayOfValues() as variant
arrayOfValues = sourceSheet.range("E1:E" & lastRow)
Dim rowIndex as long
Dim columnIndex as long
Dim splitString() as string
Dim cumulativeOffset as long
Dim toJoin(0 to 1) as string
toJoin(0) = "pull: test" ' Might speed up string concatenation below'
Dim outputArray() as string
With outputsheet.range("A1") ' The first row you want to start stacking from'
For rowIndex = 1 to lastRow
' Single dimensional, 0-based array'
splitString = VBA.strings.split(vba.strings.lcase$(arrayOfValues(rowIndex,1)), "pull: test",-1, vbbinarycompare)
Redim outputArray(1 to (ubound(splitString)+1), 1 to 1)
For columnIndex = lbound(splitString) to ubound(splitString)
toJoin(1) = splitString(columnIndex)
Outputarray(columnIndex+1,1) = VBA.strings.join(toJoin, vbnullstring)
Next columnIndex
'Instead of splitting upon a delimiter, then prepending the delimiter to each array element (as is done above), you could repeatedly call instr(), use mid$() to extract the sub-string, then increase the argument passed to the "Start" parameter in instr() (effectively moving from start to end of the string) -- until instr() returns 0. Then move on to the next string in the outer loop.'
.offset(cumulativeOffset,0).resize(Ubound(outputArray, 1), 1).value2 = outputArray
cumulativeOffset = cumulativeOffset + ubound(splitString)
Next rowIndex
End Sub

Related

How to Split Cells and Display Only Worksheet Name?

Is there a clean and tidy way to get cells split ONLY by sheet name? I have a bunch of cells that look something like this.
=(Xlookup($A2,Staff!A:A,Client!K:K)*E2
=B3*(Xlookup(E3,Auto!1:1,Desc!3:3)
And, all kinds of other stuff. Basically, I am trying to parse out only the sheet names from each cell. Each sheet name ends with a '!' character. So, I am trying to split one cell into multiple columns, based on the '!' character, and ignore any text that is not a sheet name. I tested the script below, but all it does is a basic split from one cell into multiple columns, which includes the sheet name, but all kinds of superfluous text, which I don't want.
Sub SplitData()
Const SrcCol = 1 ' A
Const TrgCol = 2 ' B
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim TheVal As String
Dim TheArr As Variant
Dim Num As Long
Application.ScreenUpdating = False
TrgRow = 1
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
TheVal = Cells(SrcRow, SrcCol).Value
TheArr = Split(TheVal, ",")
Num = UBound(TheArr) + 1
Cells(TrgRow, TrgCol).Resize(ColumnSize:=Num).Value = TheArr
TrgRow = TrgRow + 1
Next SrcRow
Application.ScreenUpdating = True
End Sub
Now:
Desired:
If you have O365, this will work for you ...
=LET(x, TRANSPOSE(FILTERXML("<d><r>" & SUBSTITUTE(A1, ",", "</r><r>") & "</r></d>", "//r[contains(text(),""!"")]")), MID(x, 1, FIND("!", x)))
... here's hoping you do, a lot easier.
Alternatively, I created my own VBA routine with the assumption that everything to the right of the formula is free to load into, just adjust for errors, names, performance, etc. as required ...
Public Sub GetWorksheets()
Dim lngRow As Long, lngColumn As Long, strFormula As String
Dim arrFormula() As String, i As Long, arrSubFormula() As String
With Sheet1
For lngRow = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
strFormula = Trim(.Cells(lngRow, 1))
lngColumn = 2
If strFormula <> "" Then
arrFormula = Split(strFormula, "!")
For i = 0 To UBound(arrFormula) - 1
arrSubFormula = Split(arrFormula(i), ",")
strFormula = arrSubFormula(UBound(arrSubFormula)) & "!"
.Cells(lngRow, lngColumn) = strFormula
lngColumn = lngColumn + 1
Next
End If
Next
End With
End Sub

Excel Range to CSVrangeoutput - split range into groups of 41 entries

Im not sure exactly how to explain this in a google search so im not sure if anyone else has asked this.
I have a vba function that takes a range and turns it into a string of comma separated values.
It works like a charm.
Now i want it to only output the first 41 entries, switch down a row and output the next 41 entries in the range.
I cant quite wrap my head around it, it feels like a simple loop but i cant quite get there.
I found the csvrange macro online somewhere :)
Function csvRange(myRange As Range)
Dim csvRangeOutput
Dim entry As Variant
For Each entry In myRange
If Not IsEmpty(entry.Value) Then
csvRangeOutput = csvRangeOutput & entry.Value & ","
End If
Next
csvRange = Left(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
Input range would look like this
Desired output would look like this, one string located in column B each group of 41 values separated on a row, offsetting 1 down each time the function hits the next nr 42.
Something like this:
Option Explicit
Public Sub test()
Debug.Print csvRange(Selection, 41)
End Sub
Public Function csvRange(ByVal myRange As Range, ByVal Columns As Long) As String
Dim csvRangeOutput
Dim iCol As Long
Dim Entry As Variant
For Each Entry In myRange
If Not IsEmpty(Entry.Value) Then
iCol = iCol + 1
csvRangeOutput = csvRangeOutput & Entry.Value
If iCol = Columns Then
csvRangeOutput = csvRangeOutput & vbCrLf
iCol = 0
Else
csvRangeOutput = csvRangeOutput & ","
End If
End If
Next
csvRange = Left$(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
will turn this data
into comma separated values with 41 columns
1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41
42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82
83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123
124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140
Alternative
Public Sub Convert()
Const ColCount As Long = 41
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 1 To LastRow Step ColCount
ws.Cells(iRow \ ColCount + 1, "B").Value = "'" & Join((WorksheetFunction.Transpose(ws.Range("A" & iRow).Resize(RowSize:=IIf(iRow + ColCount - 1 > LastRow, WorksheetFunction.Max(LastRow Mod ColCount, 2), ColCount)).Value)), ",")
Next iRow
End Sub
Please, test the next code. It will do what (I understood) you need, for as many records you have in column A:A. It should be fast, using arrays and working in memory. The single iteration is for the necessary number of range slices:
Private Sub testStringCSVArray()
Dim sh As Worksheet, arr, nrSlices As Long, LastRow As Long, rngF As Range
Dim rngStart As Range, i As Long, k As Long, h As Long, arrFin
Set sh = ActiveSheet
LastRow = sh.Range("A1").End(xlDown).row
LastRow = sh.Range("A" & rows.count).End(xlUp).row 'last row of A:A
arr = sh.Range("A1:A" & LastRow).Value 'put the range in an array
nrSlices = UBound(arr) \ 41 'determine the number of necessary slices
ReDim arrFin(nrSlices + 1)
Set rngStart = sh.Range("B" & UBound(arr) + 2) 'set the cell where the result to be returned
For i = 1 To nrSlices + 1
arrFin(h) = CStr(Join(Application.Transpose(Application.Index(arr, _
Evaluate("row(" & k + 1 & ":" & IIf(i <= nrSlices, 41 + k, UBound(arr)) & ")"), 1)), ","))
k = k + 41: h = h + 1
Next i
'Format the range where the processed data will be returned and drop the processed data array:
With rngStart.Resize(h, 1)
.NumberFormat = "#"
.Value = WorksheetFunction.Transpose(arrFin)
End With
End Sub
In order to avoid deleting of the already processed data, in case of whishing to run the code twice or more times, the processed data will be returned in column B:B, two rows down from the last cell in column A:A. If after testing, the code proves to be reliable and no need to run it one more time, Set rngStart = sh.Range("B" & UBound(arr) + 2) can be modified in Set rngStart = sh.Range("A" & UBound(arr) + 2).
Without preliminary formatting as text the area where the data will be dropped, Excel changes the NumberFormat in "scientific", when the comma delimited string contains (only) numbers of three digits each. It looks to consider the comma as a thousands separator...

Is there ability to split cells while retaining the values of adjacent columns?

The IDs column in the first table contains multiple values in each cell that needs to be split. However, the unique issue is to retain both [name] and [description] info by ID into a new table.
.
The following VBA code performs the transpose paste option. This is what I am starting with to split cells with Chr(10), or new line as the delimiter:
Sub splitText()
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)
Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row, ActiveCell.Column + 1 + totalVals)).Value = splitVals
End Sub
Other than this, I am still searching for ideas.
Maybe this will help:
Sub splitText()
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim lngRow As Long, lngEl As Long
With Sheet2
'Range A2:A5
For lngRow = 5 To 2 Step -1
splitVals = Split(.Range("A" & lngRow).Value, Chr(10))
'the first value
.Range("A" & lngRow).Value = splitVals(0)
'remaining values
For lngEl = 1 To UBound(splitVals)
.Rows(lngRow + lngEl).Insert
.Range("A" & lngRow + lngEl).Value = splitVals(lngEl)
.Range("B" & lngRow + lngEl & ":C" & lngRow + lngEl).Value = .Range("B" & lngRow & ":C" & lngRow).Value
Next lngEl
Next lngRow
End With
End Sub
Change Sheet Code/Name and Range as necessary.
Before:
After:
It's a bit more involved than your solution because you have to insert the correct number of rows below the targeted cell and then copy the IDs and the other data into the new rows. Here's an example to help you along.
There's a little "trickery" I'm using when I calculate the offset value. I'm doing this because you can assume that all arrays from the Split function will begin indexing at 0, but my personal habit is to write code that can work with either a 0 or 1 lower bound. Calculating and using an offset makes it all work for the loops and indexes.
Option Explicit
Sub test()
SplitText ActiveCell
End Sub
Sub SplitText(ByRef idCell As Range)
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(idCell.Value, Chr(10))
If LBound(splitVals) = -1 Then
'--- the split character wasn't found, so exit
Exit Sub
End If
Dim offset As Long
offset = IIf(LBound(splitVals) = 0, 1, 0)
totalVals = UBound(splitVals) + offset
Dim idSheet As Worksheet
Set idSheet = idCell.Parent
Dim idRow As Long
idRow = idCell.Row
'--- insert the number of rows BELOW the idCell to hold all
' the split values
Dim i As Long
For i = 1 To totalVals - 1
idSheet.Rows(idRow + 1).Insert
Next i
'--- now add the IDs to all the rows and copy the other columns down
Const TOTAL_COLUMNS As Long = 3
Dim j As Long
Dim startIndex As Long
startIndex = LBound(splitVals) + offset
For i = startIndex To totalVals
idCell.Cells(i, 1) = splitVals(i - offset)
For j = 2 To TOTAL_COLUMNS
idCell.Cells(i, j) = idCell.Cells(1, j)
Next j
Next i
End Sub

Search string in a range (text template) and replace from dynamic rows

Currently I have a template which is in range called rngP1.
And this contains a text below:
"This is to confirm that strTitle has been enacted on strDate for strCompany."
Basically, I have a data in another sheet that will be used to replace these 3 strings from my template:
So what I would like to happen is that in every row data it will search strings strTitle, strDate, and strCompany and replace them according to the data of each row.
I have a code already, however, it doesn't work as I expected:
Sub example()
Dim wsMain As Worksheet
Set wsMain = Sheets("Main")
Dim wsTemplate As Worksheet
Set wsTemplate = Sheets("Template")
Dim textToReplace As Variant
Dim array_example()
Dim Find_Text As Variant
Dim str As String
last_row = wsMain.Range("A1").End(xlDown).Row 'Last row of the data set
ReDim array_example(last_row - 1, 2)
Find_Text = Array("strTitle", "strDate", "strCompany")
str = wsTemplate.Range("rngP1").Value
'Storing values in the array
For i = 0 To last_row - 1
array_example(i, 0) = wsMain.Range("A" & i + 2)
array_example(i, 1) = wsMain.Range("C" & i + 2)
array_example(i, 2) = wsMain.Range("D" & i + 2)
Next
For i = LBound(array_example, 1) To UBound(array_example, 1)
For j = LBound(array_example, 2) To UBound(array_example, 2)
For a = 0 To UBound(Find_Text)
str = Replace(str, Find_Text(a), array_example(i, j))
Next a
Next j
MsgBox str
Next i
End Sub
Wrong Output:
It should be:
This is to confirm that Title1 has been enacted on 13-October-18 for Company X.
And next one would be the next row which is title 2. So on and so fort.
If you have an alternative way to do it, I appreciate it.
Here is a working example:
You can push the data range from a worksheet into an array with one line without looping
DataArr = wsMain.Range("A2:D" & LastRow).Value
You need only 2 loops for the replacing:
one to loop through the data rows
one to loop through the variables to replace
Your template str was not initialized within the loop, but you need a fresh template for every data row.
Note that the array loaded from the range starts counting from 1 but the variables array starts counting from 0.
Option Explicit
Sub Example()
Dim Template As String
Template = "This is to confirm that strTitle has been enacted on strDate for strCompany."
'load your template string from worksheet here!
Dim Variables As Variant 'variables to be replaced
Variables = Array("strTitle", "strDate", "strCompany")
Dim wsMain As Worksheet
Set wsMain = ThisWorkbook.Worksheets("Main")
Dim LastRow As Long 'this method is more reliable to find the last used row
LastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
Dim DataArr As Variant 'load the complete data range into an array
DataArr = wsMain.Range("A2:D" & LastRow).Value
Dim Output As String
Dim iRow As Long, iVar As Long
For iRow = LBound(DataArr, 1) To UBound(DataArr, 1) '1 to LastRow
Output = Template 'initialize with the template!
For iVar = LBound(Variables) To UBound(Variables) ' 0 to 2
Output = Replace(Output, Variables(iVar), DataArr(iRow, iVar + 1))
Next iVar
Debug.Print Output
Next iRow
End Sub

How to put into a cell a product of another cell with a variable?

I'm new to vba and I've been trying to make the following code work:
convert = WorksheetFunction.SumIfs(Sheets("Convert").Range("C:C"), _
Sheets("Convert").Range("A:A"), Sheets("Vista").Range("L8"), _
Sheets("Convert").Range("D:D"), Sheets("Vista").Range("C2"), _
Sheets("Convert").Range("E:E"), Sheets("Vista").Range("AC4"))
Sheets("series").Range("L2").FormulaR1C1 = _
"=RC[-8]*"&convert&"
What I'm trying to do, is to put into a variable the result of a SUMIF formula, and use that same value to multiply it with the value of another cell.
It gives me an error of "Application-defined or object-defined error".
Thank you
Arrays Again
The Eliminator
Sub Eliminator()
Dim convert As Long
'Convert = WorksheetFunction.SumIfs(Sheets("Convert").Range("C:C"), _
Sheets("Convert").Range("A:A"), Sheets("Vista").Range("L8"), _
Sheets("Convert").Range("D:D"), Sheets("Vista").Range("C2"), _
Sheets("Convert").Range("E:E"), Sheets("Vista").Range("AC4"))
'e.g.
convert = 1000
Sheets("series").Range("L2").FormulaR1C1 = "=RC[-8]*" & convert
End Sub
Blah, Blah...
Now that we have concluded that the 'Convert' line is causing the error...
Since I use Excel 2003 and you have written the formula correctly, I can only guess that since SumIfs is something like an array formula it can't always be used successfully in VBA, or maybe never!? if you have error values in cells, there might be the solution, because VBA treats them as 'VBA Errors'.
The 'SumIfsless' Solution
So I provided another solution without using SumIfs. You can run it from VBA or any other worksheet. The 'str1' commented lines are for debugging purposes. You can uncomment them and see some 'subtotals' in the Immediate window.
Sub SumIfsArray()
'Variables
'Objects
Dim oRng As Range 'Range of the Sum Column (To Calculate First and Last Row)
'Arrays
Dim arrRngAddress As Variant 'Compare Addresses
Dim arrWs As Variant 'Worksheet Names
Dim arrCol As Variant 'Three Lookup Columns and the Sum Column
Dim arrRng As Variant 'Values of the Compare Addresses
Dim arrRanges As Variant 'The Ranges of the Four Columns
Dim arrArrays As Variant 'The Values of the Four Columns
'Other
Dim iCol As Integer 'Columns Counter
Dim lngFirst As Long 'First Usable Row of Data
Dim lngLast As Long 'Last Usable Row of Data
Dim lngRows As Long 'Number of Rows of Usable Data
Dim lngRow As Long 'Rows Counter
Dim lngSum As Long 'Sum of Values
Dim blnArr As Boolean 'True if all three conditions are met.
' 'Debug Variables
' Const c1 As String = "," 'Debug String Column Separator
' Const r1 As String = vbCr 'Debug String Row Separator
' Dim i1 As Integer 'Debug String Column Counter
' Dim lo1 As Long 'Debug String Rows Counter
' Dim str1 As String 'Debug String Concatenator
'Initialize
arrRngAddress = Array("L8", "C2", "AC4")
arrWs = Array("Convert", "Vista", "series")
arrCol = Array("A:A", "D:D", "E:E", "C:C")
'Program
ReDim arrRng(1 To 3)
With Worksheets(arrWs(1)) 'Worksheet "Vista"
For iCol = 1 To 3
arrRng(iCol) = .Range(arrRngAddress(iCol - 1)).Value
Next
End With
' str1 = "The Values"
' For i1 = 1 To 3: str1 = str1 & r1 & Space(1) & arrRng(i1)
' Next: Debug.Print str1
With Worksheets(arrWs(0)) 'Worksheet "Convert"
'Number of 'usable' rows of data
Set oRng = .Range(arrCol(3))
With oRng
If .Cells(1, 1) <> "" Then
lngFirst = 1
Else
lngFirst = .Cells(1, 1).End(xlDown).Row
End If
lngLast = .Cells(.Rows.Count, .Column).End(xlUp).Row
End With
Set oRng = Nothing
lngRows = lngLast - lngFirst + 1
'Array of Ranges
ReDim arrRanges(1 To 4)
For iCol = 1 To 4
arrRanges(iCol) = Range(Cells(lngFirst, Range(arrCol(iCol - 1)).Column), _
Cells(lngLast, Range(arrCol(iCol - 1)).Column)).Address
Next
' str1 = "The Ranges"
' For i1 = 1 To 4: str1 = str1 & r1 & Space(1) & arrRanges(i1)
' Next: Debug.Print str1
'Array of Arrays
ReDim arrArrays(1 To 4)
For iCol = 1 To 4
arrArrays(iCol) = .Range(arrRanges(iCol)).Value
Next
End With
' str1 = "Values of Ranges" & r1 & Space(1) & "A,D,E,C"
' For lo1 = 1 To lngRows: str1 = str1 & r1 & Space(1): For i1 = 1 To 4
' If i1 <> 1 Then
' str1 = str1 & c1 & arrArrays(i1)(lo1, 1)
' Else: str1 = str1 & arrArrays(i1)(lo1, 1)
' End If: Next: Next: Debug.Print str1
'Sum of Values
For lngRow = 1 To lngRows
For iCol = 1 To 3
If arrArrays(iCol)(lngRow, 1) = arrRng(iCol) Then
blnArr = True
Else
blnArr = False
Exit For
End If
Next
If blnArr = True Then
lngSum = lngSum + arrArrays(4)(lngRow, 1)
End If
Next
' str1 = "The Sum": str1 = str1 & r1 & Space(1) & lngSum
'Output
'Worksheet "series"
Worksheets(arrWs(2)).Range("L2").FormulaR1C1 = "=RC[-8]*" & lngSum
End Sub
P.S. I never ever use variable names with the same name as a worksheet name in the same workbook.

Resources