VBA counting substrings in a string across a range - excel

I have been working on a worksheet in Excel and im trying to get accurate number of sub strings within a string across a range. Im using columns C and D that have text them im adding the following code to get a number of the occurrences of particular words and total them in column H by using a public function. I cannot get the code to span a range and bring back the answer. Maybe there is a better way.?
Option Compare Text
Function CountString(FullString As String, PartialString As String) As Integer
Dim cnt As Integer
cnt = 0
For i = 1 To Len(FullString)
If Mid(FullString, i, Len(PartialString)) = PartialString Then
cnt = cnt + 1
End If
Next i
CountString = cnt
End Function

A = "CatDogCatDogCatDogCatDogCatDogCatDogCatDogCatDogCatDogCatDog"
Msgbox UBound(Split(A, "Dog"))
This counts how many times dog appears in the string by using dog as a delimiter then counting how many elements in the array.
edit
Application of technique for OP:
Function CountString(FullString As String, PartialString As String) As Integer
CountString = UBound(Split(FullString, PartialString))
End Function
Edit 2
Set regEx = New RegExp
A="DogCatDogCatDogCatDogCatDogCatDogCatDogCatDogCatDogCatDogCat"
regEx.Pattern = "dog"
regEx.IgnoreCase = True
regEx.Global = True
Set MyMatches = regEx.Execute(A)
Msgbox MyMatches.Count
This counts the delimiter.
You have .test which returns true/false, .Execute which returns a collections of matches, and .replace which has many uses including replace and extracting parts of files.

Instead of your loop, I would use one single statement like
Function CountString(FullString As String, PartialString As String) As Integer
CountString = (Len(FullString) - Len(Replace(FullString, PartialString, ""))) / Len(PartialString)
End Function
(from here)

All the credit for the next code must go to #Mark. But, if on some installations the code returns wrong, please use the next variant:
Function CountString(FullString As String, PartialString As String) As Long
CountString = UBound(Split(FullString, PartialString))
If UBound(Split("x", "x")) = 2 Then CountString = CountString - 1
End Function
The way or function using to count total occurrences in a range, would be the next:
Sub countStringsInRange()
Dim sh As Worksheet, rng As Range, TotCount As Long, cel As Range, strSearch As String
strSearch = "Dog"
Set sh = ActiveSheet ' use here your sheet
Set rng = sh.Range("C8:D8") 'use here whatever range you need
For Each cel In rng
TotCount = TotCount + CountString(cel.Value, strSearch)
Next
Debug.Print TotCount
End Sub
After editing:
The next function is able to also process arrays (it works for strings, too):
Function CountStringArr(FullString As String, PartialString As Variant) As Long
Dim El As Variant, iCount As Long
If IsArray(PartialString) Then
For Each El In PartialString
iCount = iCount + UBound(Split(FullString, El))
Next
CountStringArr = iCount
Else
CountStringArr = UBound(Split(FullString, PartialString))
End If
End Function
It can be called as in the next example:
Dim x As String
x = "CatDogCatDogCatDogCatDogCatDogCatDogCatDogCatDogCatDogCatDog"
Debug.Print CountStringArr(x, Array("Dog", "Cat")) 'it returns 20
Debug.Print CountStringArr(x, "Dog") 'it returns 10
And it can be called from a range in the next way:
Sub countStringsInRangeBis()
Dim sh As Worksheet, rng As Range, TotCount As Long, cel As Range, strSearch As Variant
strSearch = Split("Dog,Cat", ",") 'or Array("Dog", "Cat")
Set sh = ActiveSheet ' use here your sheet
Set rng = sh.Range("C8:D8") 'use here whatever range you need
For Each cel In rng
TotCount = TotCount + CountStringArr(cel.Value, strSearch)
Next
Debug.Print TotCount
End Sub

Count Substrings (In a Range)
Function countString(SourceString As Range, _
ByVal SubString As String, _
Optional ByVal ignoreCase As Boolean = False) _
As Long
Dim Data As Variant, Curr As Variant
Dim i As Long, j As Long, Result As Long, iCase As Long
If ignoreCase Then iCase = 1
Data = SourceString.Value
If IsArray(Data) Then
GoSub CaseArray
Else
GoSub CaseValue
End If
countString = Result
Exit Function
CaseArray:
For i = 1 To UBound(Data)
For j = 1 To UBound(Data, 2)
Curr = Data(i, j): GoSub countValue
Next j
Next i
Return
CaseValue:
Curr = Data: GoSub countValue
Return
countValue:
If Not IsError(Curr) Then
Result = Result + UBound(Split(Curr, SubString, , iCase))
' Result = Result + (Len(Curr) _
- Len(Replace(Curr, SubString, "", , , iCase))) / Len(SubString)
End If
Return
End Function

Related

Unique count of words from text string

I have a dataset that is multiple strings and I want a unique count of the occurrences so I can review and refine my datasets. I've been unable to do this using formulas so went over to VBA, but hit a roadblock as I'm an amateur.
My data looks like this...
I want it to return this...
I've tried parsing it with text to columns, but in large datasets I have 60 columns with 100s of hits in my string. Therefore, transposing it then trying to get a count of uniques would be daunting.
Therefore, I was hoping VBA would help, but I can only seem to get a function and not with a Sub and Function to transpose then count. Something like below...
Sub Main()
Dim filename As String
Dim WorksheetName As String
Dim CellRange As String
Sheets.Add.Name = "ParsedOutput"
'==============================================================
' CHANGE THESE VALUES FOR YOUR SHEET
WorksheetName =
CellRange =
'==============================================================
' Get range
Dim Range
Set Range = ThisWorkbook.Worksheets(WorksheetName).Range(CellRange)
' Copy range to avoid overwrite
Range.Copy _
Destination:=ThisWorkbook.Worksheets("ParsedOutput").Range("A1")
' Get copied exclusions
Dim Copy
Set Copy = ThisWorkbook.Worksheets("ParsedOutput").Range("A:A")
' Parse and overwrite
Copy.TextToColumns _
Destination:=Range("A:A"), _
DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, _
Comma:=True
End Sub
Option Explicit
Public Function Counter(InputRange As Range) As String
Dim CellValue As Variant, UniqueValues As New Collection
Application.Volatile
'For error Handling On Error Resume Next
'Looping through all the cell in the defined range For Each CellValue In InputRange
UniqueValues.Add CellValue, CStr(CellValue) ' add the unique item Next
'Returning the count of number of unique values CountUniqueValues = UniqueValues.Count
End Function
For the sake of simplicity, I will take minimal data to demostrate how to achieve what you want. Feel free to change the code to suit your needs.
Excel Sheet
Let's say our worksheet looks like this
Logic:
Find last row and last column as shown HERE and construct your range.
Store the values of that range in an array.
Loop through each item in that array and extract words based of , as a delimiter and store it in the collection. If the delimiter doesnt exist then store the entire word in the collection. To create a unique collection, we use On Error Resume Next as shown in the code below.
Based on the count of words in the collection, we create an 2D array for output. One part of the array will hold the word and the other part will hold the count of occurences.
Use .Find and .FindNext to count the occurence of a word in the range and then store it in array.
Write the array in one go to the relevant cell. For demonstration purpose, I will write to Column D
Code
I have commented the code so you should not have a problem understanding it but if you do then simply ask.
Option Explicit
Sub Sample()
Dim ws As Worksheet
'~~> Change this to relevant sheet
Set ws = Sheet1
Dim LastRow As Long, LastColumn As Long
Dim i As Long, j As Long, k As Long
Dim col As New Collection
Dim itm As Variant, myAr As Variant, tmpAr As Variant
Dim OutputAr() As String
Dim aCell As Range, bCell As Range, rng As Range
Dim countOfOccurences As Long
With ws
'~~> Find last row
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find last column
LastColumn = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Construct your range
Set rng = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
'~~> Store the value in an array
myAr = rng.Value2
'~~> Create a unique collection
For i = LBound(myAr) To UBound(myAr)
For j = LBound(myAr) To UBound(myAr)
If Len(Trim(myAr(i, j))) <> 0 Then
'~~> Check data has "," delimiter
If InStr(1, myAr(i, j), ",") Then
tmpAr = Split(myAr(i, j), ",")
For k = LBound(tmpAr) To UBound(tmpAr)
On Error Resume Next
col.Add tmpAr(k), CStr(tmpAr(k))
On Error GoTo 0
Next k
Else
On Error Resume Next
col.Add myAr(i, j), CStr(myAr(i, j))
On Error GoTo 0
End If
End If
Next j
Next i
'~~> Count the number of items in the collection
i = col.Count
'~~> Create output array for storage
ReDim OutputAr(1 To i, 1 To 2)
i = 1
'~~> Loop through unique collection
For Each itm In col
OutputAr(i, 1) = Trim(itm)
countOfOccurences = 0
'~~> Use .Find and .Findnext to count for occurences
Set aCell = rng.Find(What:=OutputAr(i, 1), LookIn:=xlValues, _
Lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
countOfOccurences = countOfOccurences + 1
Do
Set aCell = rng.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
countOfOccurences = countOfOccurences + 1
Else
Exit Do
End If
Loop
End If
'~~> Store count in array
OutputAr(i, 2) = countOfOccurences
i = i + 1
Next itm
'~~> Output it to relevant cell
.Range("D1").Resize(UBound(OutputAr), 2).Value = OutputAr
End With
End Sub
Output
The following is a rough approach, and is open to tons of improvements, but should get you started.
Read the comments and adjust the code to fit your needs.
Option Explicit
Public Sub CountWordsInColumn()
' Adjust to set the sheet holding the data
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("DataSet")
' Adjust the column and row that contains the hits
Dim hitsColumn As String
Dim hitsStartRow As Long
Dim lastRow As Long
hitsColumn = "C"
hitsStartRow = 2
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, hitsColumn).End(xlUp).Row
' Adjust the column that contains the hits
Dim sourceRange As Range
Set sourceRange = sourceSheet.Range(hitsColumn & hitsStartRow & ":" & hitsColumn & lastRow)
' Add values in each cell split by ,
Dim evalCell As Range
Dim splitValues As Variant
Dim counter As Long
ReDim splitValues(lastRow - hitsStartRow)
For Each evalCell In sourceRange
splitValues(counter) = Split(evalCell.Value, ",")
counter = counter + 1
Next evalCell
' Get all values into an array
Dim allValues As Variant
allValues = AddValuesToArray(splitValues)
' Get unique values into an array
Dim uniqueValues As Variant
uniqueValues = GetUniqueValues(allValues)
' Count duplicated values from unique array
Dim outputData As Variant
outputData = CountValuesInArray(uniqueValues, allValues)
' Add new sheet
Dim outputSheet As Worksheet
Set outputSheet = ThisWorkbook.Sheets.Add
PrintArrayToSheet outputSheet, outputData
End Sub
Private Function AddValuesToArray(ByVal myArray As Variant) As Variant
Dim counter As Long
Dim tempArray As Variant
Dim tempCounter As Long
Dim tempArrayCounter As Long
ReDim tempArray(0)
For counter = 0 To UBound(myArray)
For tempCounter = 0 To UBound(myArray(counter))
tempArray(tempArrayCounter) = myArray(counter)(tempCounter)
tempArrayCounter = tempArrayCounter + 1
ReDim Preserve tempArray(tempArrayCounter)
Next tempCounter
Next counter
ReDim Preserve tempArray(tempArrayCounter - 1)
AddValuesToArray = tempArray
End Function
Private Function GetUniqueValues(ByVal tempArray As Variant) As Variant
Dim tempCol As Collection
Set tempCol = New Collection
On Error Resume Next
Dim tempItem As Variant
For Each tempItem In tempArray
tempCol.Add tempItem, CStr(tempItem)
Next
On Error GoTo 0
Dim uniqueArray As Variant
Dim counter As Long
ReDim uniqueArray(tempCol.Count - 1)
For Each tempItem In tempCol
uniqueArray(counter) = tempCol.Item(counter + 1)
counter = counter + 1
Next tempItem
GetUniqueValues = uniqueArray
End Function
Function CountValuesInArray(ByVal uniqueArray As Variant, ByVal allValues As Variant) As Variant
Dim uniqueCounter As Long
Dim allValuesCounter As Long
Dim ocurrCounter As Long
Dim outputData As Variant
ReDim outputData(UBound(uniqueArray))
For uniqueCounter = 0 To UBound(uniqueArray)
For allValuesCounter = 0 To UBound(allValues)
If uniqueArray(uniqueCounter) = allValues(allValuesCounter) Then ocurrCounter = ocurrCounter + 1
Next allValuesCounter
' This is the output
Debug.Print uniqueArray(uniqueCounter), ocurrCounter
outputData(uniqueCounter) = Array(uniqueArray(uniqueCounter), ocurrCounter)
ocurrCounter = 0
Next uniqueCounter
CountValuesInArray = outputData
End Function
Private Sub PrintArrayToSheet(ByVal outputSheet As Worksheet, ByVal outputArray As Variant)
Dim counter As Long
For counter = 0 To UBound(outputArray)
outputSheet.Cells(counter + 1, 1).Value = outputArray(counter)(0)
outputSheet.Cells(counter + 1, 2).Value = outputArray(counter)(1)
Next counter
End Sub
Try,
It is convenient to use Dictionary to extract duplicate items.
Sub test()
Dim Ws As Worksheet, wsResult As Worksheet
Dim vDB, vSplit, v
Dim Dic As Object 'Scripting.Dictionary
Dim i As Long, n As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Ws = Sheets(1) 'ActiveSheet
vDB = Ws.Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
vSplit = Split(vDB(i, 3), ",")
For Each v In vSplit
If Dic.Exists(v) Then
Dic(v) = Dic.Item(v) + 1
Else
Dic.Add v, 1
End If
Next v
Next i
Set wsResult = Sheets(2)
n = Dic.Count
With wsResult
.UsedRange.Clear
.Range("a1").Resize(n) = WorksheetFunction.Transpose(Dic.Keys)
.Range("b1").Resize(n) = WorksheetFunction.Transpose(Dic.Items)
End With
End Sub
For all who won't use VBA.
Here a solution with PowerQuery:
Quelle = Excel.CurrentWorkbook(){[Name="tbl_Source"]}[Content],
Change_Type = Table.TransformColumnTypes(Quelle,{{"ID", Int64.Type}, {"Record", type text}, {"Hits", type text}}),
Split_Hits = Table.ExpandListColumn(Table.TransformColumns(Change_Type, {{"Hits", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Hits"),
Clean_Spaces = Table.ReplaceValue(Split_Hits," ","",Replacer.ReplaceText,{"Hits"}),
Group_Rows = Table.Group(Clean_Spaces, {"Hits"}, {{"Count", each Table.RowCount(_), Int64.Type}})
in
Group_Rows
Approach simulating newer TextJoin and Unique functions
In order to complete the above solutions, I demonstrate an approach using
[1]a) a replacement of the TextJoin function (available since vers. 2019, MS 365 ~> the newer function code is commented out,btw),
[1]b) the FilterXML() function to get unique words (available since vers. 2013+) and
[3]a) a negative filtering to calculate results
Sub wordCounts()
'[0]define data range
With Sheet3
Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim rng As Range: Set rng = .Range("A2:A" & lastRow)
End With
With WorksheetFunction
'[1]split a) available and b) unique words into arrays
' Dim words: words = Split(.TextJoin(",", True, rng), ",") ' (available vers. 2019+ or MS 365)
Dim words: words = Split(Join(.Transpose(rng), ","), ",") '
Dim uniques: uniques = UniqueXML(words) ' (already since vers. 2013+)
'[2]provide for calculation
'fill temporary array with words
Dim tmp: tmp = words
'declare cnt array for counting results
Dim cnt: ReDim cnt(0 To UBound(uniques), 0 To 0)
Dim old As Long: old = UBound(tmp) + 1 ' remember original size
'[3]get word counts
Dim elem
For Each elem In uniques
'a) filter out current elem
tmp = Filter(tmp, elem, False)
Dim curr As Long: curr = UBound(tmp) + 1
'b) count number of words (as difference of filtered tmp boundaries) ...
Dim n As Long: n = old - curr
' ... and remember latest array boundary
old = curr
'c) assign results to array cnt
Dim i As Long: cnt(i, 0) = n
i = i + 1 ' increment counter
Next elem
'[4]write word counts to target
rng.Offset(0, 2).Resize(UBound(uniques), 1) = .Transpose(uniques)
rng.Offset(0, 3).Resize(UBound(cnt), 1) = cnt
End With
End Sub
Help function UniqueXML()
Function UniqueXML(arr, Optional Delim As String = ",", Optional ZeroBased As Boolean = False)
' Purp: return unique list of array items
' Note: optional argument Delim defaulting to colon (",")
' Help: https://learn.microsoft.com/de-de/office/vba/api/excel.worksheetfunction.filterxml
' [1] get array data to xml node structure (including root element)
Dim wellformed As String
wellformed = "<root><i>" & Join(arr, "</i><i>") & "</i></root>"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' [2] define XPath string searching unique item values
' Note: c.f. udf: https://stackoverflow.com/questions/58677041/vba-excel-how-to-display-non-equal-values-in-an-excel-array/58685756#58685756
' ------------------------------------------------
' //i ... all <i> node values after the DocumentElement
' [not( .=preceding::i)] ... only if not preceded by siblings of the same node value
' ------------------------------------------------
Dim myXPath As String
myXPath = "//i[not( .=preceding::i)]"
' [3] get "flat" 1-dim array (~> one-based!)
Dim tmp As Variant
tmp = Application.Transpose(WorksheetFunction.FilterXML(wellformed, myXPath))
' [3a] optional redim as zero-based array
If ZeroBased Then ReDim Preserve tmp(LBound(tmp) - 1 To UBound(tmp) - 1)
' [4] return function result
UniqueXML = tmp
End Function
I didn't understand the problem you have between sub or function; however, this is a function that counts the unique values in a range
Public Function Counter(InputRange As Variant) As Variant
Dim UniqueValues As New Collection
Dim Val As Variant
Dim Cell As Range
Dim I As Long
Application.Volatile
On Error Resume Next
For Each Cell In InputRange
Val = Split(Cell, ",")
If IsArray(Val) Then
For I = LBound(Val) To UBound(Val)
UniqueValues.Add Val(I), CStr(Val(I))
Next I
Else
UniqueValues.Add Val, CStr(Val)
End If
Next Cell
On Error GoTo 0
Counter = UniqueValues.Count
End Function

Create Table from variable name Values

I would like to create the table based on the "Header" name and it's last row of the table.
I could found the Header start address and Length of the table also using some formulas.
For Example:
FindHeaderValue as 14 i.e, $B$14
TableLength as 65, i.e, $V$65
Hence, I would like to create the Table with the range for
$B$FindHeaderValue:$V$TableLength .
Because the FindHeaderValue and TableLength will vary Excel to Excel.
Please help to figure out the solution for the same. Thank you so much in advance.
Sub Test()
Dim sFindHeader As String
Dim oRangeFindHeader As Range, FirstRange As String, LastRange As String
Dim FindHeaderValue As Integer, FindLength As Integer, TableLength As Integer
Dim Ws As Worksheet
Set Ws = ThisWorkbook.Sheets("Sheet1")
Set oRangeFindHeader = Worksheets("8A52").Range("B1:V5000").Find("BBBB", lookat:=xlPart)
sFindHeader = oRangeFindHeader.Address(ReferenceStyle:=xlR1C1)
FindHeaderValue = GetNumber(sFindHeader)
FirstRange = oRangeFindHeader.Address
MsgBox FindHeaderValue
MsgBox FirstRange
FindLength = FindHeaderValue + 2
TableLength = Cells(FindLength, 13).End(xlDown).Row
MsgBox TableLength
Ws.ListObjects.Add(xlSrcRange, Ws.Range("$B$FindHeaderValue:$V$TableLength"), , xlYes).Name = "DefinitionTable"
Ws.ListObjects("DefinitionTable").TableStyle = "TableStyleLight1"
End Sub
Public Function GetNumber(s As String) As Long
Dim b As Boolean, i As Long, t As String
b = False
t = ""
For i = 1 To Len(s)
If IsNumeric(Mid(s, i, 1)) Then
b = True
t = t & Mid(s, i, 1)
Else
If b Then
GetNumber = CLng(t)
Exit Function
End If
End If
Next i
End Function
Variables don't belong inside quotes. Use & to concatenate them into the range address (which doesn't need $ by the way):
Ws.Range("B" & FindHeaderValue & ":V" & TableLength)

Unable to search and replace the values using column headers

I'm trying to create a vba script that will search for the _ in all the cells fallen under Crude Items column. However, when it finds one, it will split the values from _ and place the rest in corresponding cells fallen under Refined Ones column.
I've tried with the following which is doing the job flawlessly but I wish to search and replace the values using column headers:
Sub CopyAndReplace()
Dim cel As Range
For Each cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).row)
If cel.value <> "" Then
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
End If
Next cel
End Sub
To let you visualize how the sheet might look like:
How can I search and replace the values using column headers?
I am not sure this is what you are after, but a few important mentions...
Try to always use at least a worksheet qualifier when writing your code. How else is your program going to know explicitly where you would like it to operate?
I have changed your process slightly, but again, not sure if this is exactly what you are after. See below code.
Sub SplitByHeader()
Dim i As Long
Dim crudeHeader As Range, refinedHeader As Range
Dim ws As Worksheet
'set ws
Set ws = ThisWorkbook.Sheets("Sheet1")
'set header ranges
Set crudeHeader = ws.Rows(1).Find(What:="Crude Items", LookAt:=xlWhole)
Set refinedHeader = ws.Rows(1).Find(What:="Refined Ones", LookAt:=xlWhole)
'simple error handler
If crudeHeader Is Nothing Or refinedHeader Is Nothing Then Exit Sub
For i = 2 To ws.Cells(ws.Rows.Count, crudeHeader.Column).End(xlUp).Row
If ws.Cells(i, crudeHeader.Column).Value <> "" Then
ws.Cells(i, refinedHeader.Column).Value = Split(ws.Cells(i, crudeHeader.Column).Value, "_")(1)
End If
Next i
End Sub
I have just tried this one with the code below:
It is a good idea to add additional check to the condition, like this - If myCell.Value <> "" And InStr(1, myCell, "_") Then to avoid starting from A2.
The idea is that the LocateValueCol locates the column of the first row, which has the string, passed to it. Knowing this, it works ok.
Option Explicit
Sub CopyAndReplace()
Dim searchColumn As Long
searchColumn = LocateValueCol("SearchCol", Worksheets(1))
Dim replaceColumn As Long
replaceColumn = LocateValueCol("ReplaceCol", Worksheets(1))
Dim myCell As Range
Dim lastCell As Long
With Worksheets(1)
lastCell = .Cells(.Rows.Count, searchColumn).End(xlUp).Row
For Each myCell In .Range(.Cells(1, searchColumn), .Cells(lastCell, searchColumn))
If myCell.Value <> "" And InStr(1, myCell, "_") Then
.Cells(myCell.Row, replaceColumn) = Split(myCell, "_")(1)
End If
Next
End With
End Sub
This is the function, locating the columns. (If you have ideas for improvement, feel free to make a PR here):
Public Function LocateValueCol(ByVal textTarget As String, _
ByRef wksTarget As Worksheet, _
Optional rowNeeded As Long = 1, _
Optional moreValuesFound As Long = 1, _
Optional lookForPart = False, _
Optional lookUpToBottom = True) As Long
Dim valuesFound As Long
Dim localRange As Range
Dim myCell As Range
LocateValueCol = -999
valuesFound = moreValuesFound
Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.Count))
For Each myCell In localRange
If lookForPart Then
If textTarget = Left(myCell, Len(textTarget)) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
Else
If textTarget = Trim(myCell) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
End If
Next myCell
End Function
Private Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1)
valueToIncrement = valueToIncrement + incrementWith
End Sub
Private Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1)
valueToDecrement = valueToDecrement - decrementWith
End Sub
For fun using regex and dynamically finding header columns. You can swop out the regex based function for your own and still have the dynamic column finding.
Option Explicit
Public Sub test()
Dim i As Long, inputs(), re As Object, ws As Worksheet
Dim inputColumn As Range, outputColumn As Range, inputColumnNumber As Long, outputColumnNumber As Long
Const SEARCH_ROW As Long = 1
Const INPUT_HEADER As String = "Crude items"
Const OUTPUT_HEADER As String = "Refined Ones"
Const START_ROW = 2
Set re = CreateObject("VBScript.RegExp")
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set inputColumn = GetColumnByHeader(ws, SEARCH_ROW, INPUT_HEADER)
Set outputColumn = GetColumnByHeader(ws, SEARCH_ROW, OUTPUT_HEADER)
If inputColumn Is Nothing Or outputColumn Is Nothing Then Exit Sub
inputColumnNumber = inputColumn.Column
outputColumnNumber = outputColumn.Column
With ws
inputs = Application.Transpose(.Range(.Cells(START_ROW, inputColumnNumber), .Cells(.Cells(.Rows.Count, inputColumnNumber).End(xlUp).Row, inputColumnNumber)).Value)
For i = LBound(inputs) To UBound(inputs)
inputs(i) = GetMatch(re, inputs(i))
Next
.Cells(START_ROW, outputColumnNumber).Resize(UBound(inputs), 1) = Application.Transpose(inputs)
End With
End Sub
Public Function GetColumnByHeader(ByVal ws As Worksheet, ByVal SEARCH_ROW As Long, ByVal columnName As String) As Range
Set GetColumnByHeader = ws.Rows(SEARCH_ROW).Find(columnName)
End Function
Public Function GetMatch(ByVal re As Object, ByVal inputString As String) As String
With re
.Global = True
.MultiLine = True
.Pattern = "_(.*)"
If .test(inputString) Then
GetMatch = .Execute(inputString)(0).SubMatches(0)
Else
GetMatch = inputString 'or =vbNullString if want to return nothing
End If
End With
End Function
If you are working through an actual table things will become quite easy:
Sub Test()
Dim arr(), x As Long
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
For Each cl In .Range("Table1[Crude Items]") 'Change Table1 accordingly
ReDim Preserve arr(x)
If InStr(cl, "_") > 0 Then
arr(x) = Split(cl, "_")(1)
Else
arr(x) = ""
End If
x = x + 1
Next cl
.Range("Table1[Refined Ones]").Value = Application.Transpose(arr)
End With
End Sub
There is a check for "_". If not there, the cell will be kept empty.
You can also consider to use formula to do it.
I am not clear about what you want to replace "_" character with. For example, iff you replace the following line of your script:
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
with this one:
Sheets("Sheet1").Range(cel(1, 3).Address) = WorksheetFunction.Substitute(cel, "_", "")
The above line should replace the "_" character with nothing from the cells in the Crude_Items column
And as Lee said, you can also consider using formula in the worksheet if you do not have significant amount of data

How to transpose different sized rows into one column

I'm pretty new to Excel VBA and I am currently trying to take data from multiple rows and transpose it into a single column. I know where the first cell of the data will begin, but that's all I know. Each row of data is a different sized row, and there can be a varying number of columns also.
So my current method is using a sort of transpose where I just select a very large range (in hopes that it captures all my data) and then transposing it. It does work, albeit pretty slow, and it also includes all the blanks in my range also.
Sub transpose()
Dim InputRange As Range
Dim OutputCell As Range
Set InputRange = Sheets("Sheet1").Range("P1:AC100")
'output will begin at this cell and continue down.
Set OutputCell = Sheets("Sheet1").Range("A1")
For Each cll In InputRange
OutputCell.Value = cll.Value
Set OutputCell = OutputCell.Offset(1, 0)
Next
End Sub
The current method isn't the worst, but I'm sure there are better methods that are quicker and ignore blanks. I'm not sure if an actual transpose is the best way, or perhaps using some sort of loop method. The data is usually contained within 200 rows, and 10 columns if that helps in deciding a method (maybe looping might be quick enough). Any help would be appreciated!
Edit
I have found a method of ignoring the blanks:
For Each cll In InputRange
If Not IsEmpty(cll.Value) Then
OutputCell.Value = cll.Value
Set OutputCell = OutputCell.Offset(1, 0)
End If
Next
This 'snake' method works fine for me.
Sub Snake()
Dim N As Long, i As Long, K As Long, j As Long
Dim sh1 As Worksheet, sh2 As Worksheet
K = 1
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
N = sh1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
For j = 1 To Columns.Count
If sh1.Cells(i, j) <> "" Then
sh2.Cells(K, 1).Value = sh1.Cells(i, j).Value
K = K + 1
Else
Exit For
End If
Next j
Next i
End Sub
Before:
After:
One thing you could do is instead of looping the entire range just loop the SpecialCells.
Depending on what the content is of your inputRange then you can choose which XlCellType to use.
If it is just hardcoded values then xlCellTypeConstants would work fine for you.
Alternatively, you might be looking at formulas, in which case you would want to use xlCellTypeFormulas.You can also do a Union if you need both.
Here is an example using just xlCellTypeConstants
Sub transposes()
' Example just for hardcoded data
Dim inputRange As Range
Set inputRange = Sheets("Sheet1").Range("P1:AC100").SpecialCells(xlCellTypeConstants)
Dim outputCell As Range
Set outputCell = Sheets("Sheet1").Range("A1")
Dim cell As Range
For Each cell In inputRange
Dim offset As Long
outputCell.offset(offset).Value = cell.Value
offset = offset + 1
Next cell
End Sub
Option Explicit
Public Sub Range_2_Column_Skip_VbNUllString()
' Test Covered
'
Range_2_Column Cells(1, 1).CurrentRegion, _
Cells(1, 5), vbNullString
End Sub
Public Function Range_2_Column( _
ByVal r_Sour As Range, _
cell_Dest As Range, _
ByVal sKip As String)
' Test Covered
A2_2_Range A2_From_Coll( _
Coll_From_A2_Skip( _
A2_From_Range(r_Sour), sKip)), cell_Dest
End Function
Public Sub A2_2_Range( _
a2() As Variant, _
cell As Range)
' Test Covered
cell.Resize( _
UBound(a2), UBound(a2, 2)).Value = _
a2
End Sub
Public Function A2_From_Range( _
ByVal r As Range) _
As Variant()
' Test Covered
'
A2_From_Range = r.Value
End Function
Public Function Coll_From_A2_Skip( _
a2() As Variant, _
ByVal sKip As String) _
As Collection
' Test Covered
'
Dim coll As New Collection
Dim v As Variant
For Each v In a2
If v <> sKip Then
coll.Add v
End If
Next
Set Coll_From_A2_Skip = coll
End Function
Public Function A2_From_Coll( _
ByVal coll As Collection) _
As Variant()
' Test Covered
'
ReDim a2(1 To coll.Count, 1 To 1) As Variant
Dim v As Variant
Dim iCount As Long
iCount = 1
For Each v In coll
a2(iCount, 1) = v
iCount = iCount + 1
Next
A2_From_Coll = a2
End Function

Sub slows down when called multiple times

I am trying to filter data on 3 different sheets using this code, but the filterBy sub runs dramatically slower on the second and third sheet when I use expressPrepper to do it all in one click.
I'm guessing the second and third filter by run approximately 1/200 the speed of the first one. I can't figure out why.
All three sheets contain similar data, although the third is actually shorter (~6500 rows) than the first two (~16000 rows each).
Any help would be greatly appreciated!
Sub filterBy(filterlist As String, col As String, sht As String)
Dim myArr As Variant
myArr = buildArray(filterlist)
clean myArr, col, sht
End Sub
Function buildArray(filterlist As String) As Variant
Dim myTable As ListObject
Dim TempArray As Variant
Select Case filterlist
Case Is = "I"
Set myTable = Sheets("Competitive Set").ListObjects("Table1")
TempArray = myTable.DataBodyRange.Columns(1)
buildArray = Application.Transpose(TempArray)
Case Is = "T"
Set myTable = Sheets("Competitive Set").ListObjects("Table1")
TempArray = myTable.DataBodyRange.Columns(2)
buildArray = Application.Transpose(TempArray)
Case Is = "IB"
Set myTable = Sheets("Competitive Set").ListObjects("Table2")
TempArray = myTable.DataBodyRange.Columns(1)
buildArray = Application.Transpose(TempArray)
Case Is = "TB"
Set myTable = Sheets("Competitive Set").ListObjects("Table2")
TempArray = myTable.DataBodyRange.Columns(2)
buildArray = Application.Transpose(TempArray)
Case Is = "AB"
Set myTable = Sheets("Competitive Set").ListObjects("Table3")
TempArray = myTable.DataBodyRange.Columns(1)
buildArray = Application.Transpose(TempArray)
End Select
End Function
Sub clean(arr As Variant, col As String, sht As String)
Dim IsInArray As Long
Dim product As String
Dim lastRow As Long, i As Long
Dim progress As Double
With Sheets(sht)
lastRow = .Cells(Rows.Count, col).End(xlUp).Row
For i = lastRow To 2 Step -1
product = .Cells(i, col).Value
IsInArray = UBound(filter(arr, product))
If IsInArray < 0 Then
.Rows(i).EntireRow.Delete
End If
progress = ((lastRow - i) / lastRow) * 100
progress = Round(progress, 2)
Debug.Print progress
Next i
End With
End Sub
Sub expressPrepper()
filterBy "AB", "C", "Spend"
filterBy "AB", "C", "IMP"
filterBy "AB", "C", "GRP"
End Sub
If I understand your program correctly there should be no need for filtering and, hence, no problem from applying thousands of filters. I have re-written your program - the way I understood it - without such need, basically, deleting rows which don't have a duplicate in the designated column. The code is untested.
Sub ExpressFilter()
Dim Flt() As String, i As Integer
Dim Sp() As String, j As Integer
Dim TblName As String
Dim ClmRng As Range
Flt = Split("AB,C,Spend|AB,C,IMP|AB,C,GRP", "|")
For i = 0 To UBound(Flt)
Sp = Split(Flt(i), ",")
Select Case Sp(0)
Case Is = "I"
TblName = "Table1"
C = 1
Case Is = "T"
TblName = "Table1"
C = 2
Case Is = "IB"
TblName = "Table2"
C = 1
Case Is = "TB"
TblName = "Table2"
C = 2
Case Is = "AB"
TblName = "Table3"
C = 1
End Select
Set ClmRng = Worksheets("Competitive Set").ListObjects(TblName).DataBodyRange.Columns(C)
DeleteSingles ClmRng, Columns(Sp(1)).Column, Sp(2)
Next i
End Sub
Private Sub DeleteSingles(ClmRng As Range, _
C As Long, _
Sht As String)
Dim Fnd As Range
Dim IsInArray As Long
Dim lastRow As Long, R As Long
With Sheets(Sht)
lastRow = .Cells(Rows.Count, C).End(xlUp).Row
For R = lastRow To 2 Step -1
With ClmRng
Set Fnd = .Find(What:=.Cells(R, C).Value, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
MatchCase:=False)
End With
If Fnd Is Nothing Then .Rows(R).EntireRow.Delete
If (R Mod 25 = 0) or (R = 2) Then
Application.StatusBar = Round(((lastRow - R) / lastRow) * 100, 0) & "% done"
End If
Next R
End With
End Sub
Note that the progress is shown in the Status Bar at the left bottom of the screen.

Resources