Check wether a set of data already exists in current worksheet - excel

I have a large table filled with data. What I want to do is check wether a set of data already exists within this table. I have inserted the data I am looking for in a separate worksheet. The Range with the table items I am looking for I called "SearchedData" and the Area where I am checking wether it holds the data I am looking for I called "SearchArea".
My code only shows me the data would exist but in the worksheet I am working on it doesn't so there must be something wrong with my code. Any help on this would be very much appreciated!
Sub CheckWetherDataExists()
Dim SearchedData As Variant
Dim SearchArea As Variant
SearchedData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
SearchArea = ThisWorkbook.Worksheets("Tabelle1").Range("A:E").Value
If SearchArea = SearchedData Then
MsgBox ("Searched Data already exists")
Else: MsgBox ("Searched Data is missing")
End If
End Sub

This is a way more complicated to solve.
Imagine Tabelle2 as following:
And Tabelle1 as following:
I suggest to use the Range.Find method to find the first occurenc of the first cells data here this is represented by 11. And then check if the rest of the data is right/below there too. Do this in a loop until all occurences are checked.
So in Tabelle1 the yellow areas will be ckecked but the only full match is at A14:E17 which will be considered as duplicate.
Option Explicit
Public Sub CheckIfDataExists()
Dim wsSearch As Worksheet
Set wsSearch = ThisWorkbook.Worksheets("Tabelle1")
Dim SearchRange As Range
Set SearchRange = wsSearch.Range("A1", wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp))
Dim SearchData() As Variant 'data array
SearchData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
Dim FoundData() As Variant
'remember first find to prevent endless loop
Dim FirstFoundAt As Range
Set FirstFoundAt = SearchRange.Find(What:=SearchData(1, 1), After:=SearchRange.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FirstFoundAt Is Nothing Then
Dim FoundAt As Range
Set FoundAt = FirstFoundAt
Do
Set FoundAt = SearchRange.Find(What:=SearchData(1, 1), After:=FoundAt, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FoundAt Is Nothing Then
FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Select
FoundData = FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Value
If AreArraysEqual(SearchData, FoundData) Then
MsgBox "data found at " & FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Address
Exit Sub
End If
End If
Loop Until FoundAt Is Nothing Or FirstFoundAt.Row >= FoundAt.Row
End If
MsgBox "data not found"
End Sub
Private Function AreArraysEqual(Arr1 As Variant, Arr2 As Variant) As Boolean
Dim iRow As Long, iCol As Long
'default
AreArraysEqual = True
For iRow = LBound(Arr1, 1) To UBound(Arr1, 1)
For iCol = LBound(Arr1, 2) To UBound(Arr1, 2)
If Arr1(iRow, iCol) <> Arr2(iRow, iCol) Then
AreArraysEqual = False
Exit Function
End If
Next iCol
Next iRow
End Function

I believe this code will do what you want reasonably fast.
Sub CheckWetherDataExists()
Dim SearchedData As Variant
Dim SearchArea As Variant
Dim LookFor() As String
Dim LookIn() As String
Dim R As Long, C As Long
SearchedData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
LookFor = MergedRows(SearchedData)
With ThisWorkbook.Worksheets("Tabelle1")
SearchArea = .Range(.Cells(2, 1), .Cells(.Rows.Count, 5).End(xlUp)).Value
End With
LookIn = MergedRows(SearchArea)
For R = 1 To UBound(LookIn)
If LookIn(R) = LookFor(1) Then
If R < UBound(LookIn) - 2 Then
For C = 2 To UBound(LookFor)
If LookIn(R + C - 1) <> LookFor(C) Then Exit For
Next C
If C > UBound(LookFor) Then
MsgBox "Match found in Row " & R
Exit For
End If
End If
End If
Next R
End Sub
Private Function MergedRows(RngVal As Variant) As String()
Dim Fun() As String
Dim R As Long, C As Long
ReDim Fun(1 To UBound(RngVal))
For R = 1 To UBound(RngVal)
For C = 1 To UBound(RngVal, 2)
Fun(R) = Fun(R) & "," & RngVal(R, C)
Next C
Next R
MergedRows = Fun
End Function
The code creates merged strings of 5 cells of both the SearchedData and the SearchArea data. This job is done by the Function MergedRows. In the process the SearchedData turn into array LookFor(1 To 3) and LookIn(1 To LastRow). Next the first element (representing a row) of LookFor is compared to each element (representing a row) of LookIn. If a match is found the other two rows are also compared. When all three elements (rows) match a message is issued and the search is terminated.

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

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

Loop through cells and display a message if a value is not found

I have a macro that loops through cells of one sheet, looks for that value in another sheet, and then highlights the row if they match. I'd like to add a message box that would pop up if a matching value is not found. I know this is a simple problem, but I'm having trouble figuring out in which loop to put my booleans.
Sub MarkXfer_noX()
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim j As Integer
Dim ProdCI As String
Dim found As Boolean
Dim intRowCount As Integer
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
For j = 2 To rng2.Rows.count 'from row 2 to the end
If rng2.Cells(j, 2) = ProdCI Then 'if the ProdCI in column B matches the one we picked,
Call FillCell(j) 'call a sub in a different module and give it our current row
found = True
Else
found = False
End If
Next
Next
If found = False Then
MsgBox (ProdCI & " not found") 'Display a message if one of the items wasn't found on the main page. Currently has an error where the last one in the list always pops up.
Else
End If
End Sub
Right now it always shows a msgbox with the last value in the range no matter what.
Thanks all, here is the updated working code using the Find function
Sub MarkXfer_Find()
'Re-tooled to use the .Find function instead of looping through each
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim ProdCI As String
Dim intRowCount As Integer
Dim intRowCount2 As Integer
Dim aCell As Range
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
intRowCount2 = Worksheets("All_ProCI").UsedRange.Rows.count
'use the Find function to put a value in aCell
Set aCell = rng2.Range("B1:B" & intRowCount2).Find(What:=ProdCI, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'MsgBox ProdCI & " found"
Call FillCell(aCell.row)
Else 'If aCell is blank display msgbox
MsgBox "ProdCI """ & ProdCI & """ not found"
End If
Next
End Sub

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

Concatenate the values in one column separated by '/' based on the values assigned to the another column

I have an excel sheet which contains two columns called ProductName and CountryCode.i wanted to concatenate all the CountryCode separated by / based on the corresponding values in the column 'ProductName' and My output would be obtained in a separate column called 'FinalResults'. Please note that I used remove duplicate function to get unique values in Column C from Column A.
I tried the below VBA code with the help of stackoverflow and got the results.
Sub ProductCountry()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")
Dim FoundCell As Range, SearchRange As Range, Names As Range, SearchCell As Range
Dim MyString As String, i As Long
Set SearchRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
SearchRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("C2"), Unique:=True
ws.Range("C2").Delete Shift:=xlShiftUp
Set Names = ws.Range("C2:C" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)
For Each SearchCell In Names
Set FoundCell = SearchRange.Find(SearchCell)
For i = 1 To Application.WorksheetFunction.CountIf(SearchRange, SearchCell)
MyString = MyString & FoundCell.Offset(, 1) & "/"
Set FoundCell = SearchRange.FindNext(FoundCell)
Next i
SearchCell.Offset(, 1) = Left(MyString, Len(MyString) - 1)
MyString = ""
Next SearchCell
End Sub
Seems it works fine except for the first product PRO1. You could see it didn't concatenate the codes orderly and skipped the country code US and took the country code SG two times instead.
Can anyone help what went wrong in this script and I also got range error sometime if I use this same code for large data.
I rewrote it ...
Public Function ConcatenateCodes(ByVal strProductName As String, ByVal rngCells As Range, Optional ByVal strDelimiter As String = "/") As String
Application.Volatile
Dim objCell As Range, lngRow As Long, lngCol As Long, strThisProductName As String
Dim strCountry As String, lngBlank As Long
For lngRow = 1 To rngCells.Rows.Count
strThisProductName = Trim(rngCells.Cells(lngRow, 1))
strCountry = Trim(rngCells.Cells(lngRow, 2))
If strThisProductName & strCountry = "" Then
lngBlank = lngBlank + 1
Else
lngBlank = 0
If strProductName = strThisProductName Then
ConcatenateCodes = ConcatenateCodes & strDelimiter & strCountry
End If
End If
If lngBlank = 10 Then Exit For
Next
If ConcatenateCodes <> "" Then ConcatenateCodes = Mid(ConcatenateCodes, 2)
End Function
... I'm comfortable with the above but that's just me. It means the data doesn't need to be sorted and it will work.
Add the formula to your cell and watch it go.
If you concern about speed you should use arrays to handle your data:
Option Explicit
Public Sub CollectList()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'read values into array
Dim InputValues() As Variant
InputValues = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, 1)).Value
Dim UniqueList As Object
Set UniqueList = CreateObject("Scripting.Dictionary")
'collect all products in a dictionary
Dim iRow As Long
For iRow = 1 To UBound(InputValues, 1)
If UniqueList.Exists(InputValues(iRow, 1)) Then
UniqueList(InputValues(iRow, 1)) = UniqueList(InputValues(iRow, 1)) & "/" & InputValues(iRow, 2)
Else
UniqueList.Add InputValues(iRow, 1), InputValues(iRow, 2)
End If
Next iRow
'output dictionary into cells
iRow = 2 'start output in row 2
Dim itm As Variant
For Each itm In UniqueList
ws.Cells(iRow, "C").Value = itm
ws.Cells(iRow, "D").Value = UniqueList(itm)
iRow = iRow + 1
Next itm
End Sub
As can be seen by the other responses, there are many ways to accomplish your task.
But read VBA HELP for the Range.Find method
I submit the following to help you understand where you went wrong:
This is your problem line:
Set FoundCell = SearchRange.Find(SearchCell)
You only specify the what argument for the Find. So other arguments default to some uncontrolled value. In general, the after argument will default to the beginning of the range, so the first matching term you will Find for PRO1 will be in A3. Also, the 2nd SG is being picked up because the lookat is defaulting to xlPart and PRO1 is contained within PRO10.
So one way of correcting that portion of your code, would be to be sure to specify all the relevant arguments of the Find. eg:
Set FoundCell = SearchRange.Find(what:=SearchCell, after:=SearchRange.End(xlDown), lookat:=xlWhole)

Resources