Before I start, I just want to thank every contributor ahead of time. I've only posted one question before, and I was amazed at how quickly I got responses and how much I learned after studying the solution. I'm hoping I will have enough reputation points soon to start upvoting good solutions I find here.
Anyways, what I'm trying to do is return one number, and that number is the maximum number of names that appear in a single cell of a worksheet column. Each cell in that column can have any number of names in it. Each name is delimited by a pipe "|", so I count the pipes and then add one to get the number of names in each cell. For example: Cell value is "Bob | Jon | Larry" = 2pipes +1 = 3 names.
My code below works, but I need to do this on tens of thousands of records. I don't think my solution is a good or efficient way to do it (tell me if I'm wrong). So my questions are:
Is there a better way to accomplish this, such as without looping through every cell in the range?
If there isn't a totally different approach to this, how can I avoid actually printing the name counts in cells in a new column? Could I store these values in an array and calculate the max of the array? (maybe there is already a thread on this topic you could point me to?)
Sub charCnt()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = Worksheets("Leasing")
Dim vRange As Variant
Dim iCharCnt As Integer
Dim iRows As Integer
Dim i As Integer
Dim iMax As Integer
Const sFindChar As String = "|"
iRows = ws.Cells(Rows.Count, "A").End(xlUp).Row 'count number of rows
For i = 1 To iRows
vRange = Cells(i, "O") 'column O has the names
iCharCnt = Len(vRange) - Len(Replace(vRange, sFindChar, "")) 'find number of | in single cell.
ws.Cells(i, "W") = iCharCnt 'column W is an empty column I use to store the name counts
Next i
iMax = Application.WorksheetFunction.Max(Range("W:W")) + 1 'return max from column W
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Max number of names in one cell is " & iMax) ' show result
End Sub
Max Number of Substrings
Option Explicit
Sub charCount()
Const cCol As String = "O"
Const fRow As Long = 1
Const Delimiter As String = "|"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Leasing")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, cCol).End(xlUp).Row
Dim rg As Range: Set rg = ws.Cells(fRow, cCol).Resize(lRow - fRow + 1)
Dim Data As Variant: Data = rg.Value
Dim i As Long
For i = 1 To UBound(Data, 1)
Data(i, 1) = Len(Data(i, 1)) - Len(Replace(Data(i, 1), Delimiter, ""))
Next i
Dim iMax As Long: iMax = Application.Max(Data) + 1
MsgBox ("Max number of names in one cell is " & iMax) ' show result
End Sub
A close-to-formula approach
Combining worksheet functions CountA() and FilterXML() allows to get all substring counts separated by the pipe character |:
Sub CountSubstrings(StartCell As Range, TargetRng As Range)
'Purp.: count items separated by pipes
'Meth.: via worksheetfunction FILTERXML()
'Note: assumes target in same sheet as StartCell (could be changed easily)
'a) enter formula into entire target range
Const PATTERN$ = _
"=IF(LEN($),COUNTA(FILTERXML(""<t><s>""&SUBSTITUTE($,""|"",""</s><s>"")&""</s></t>"",""//s"")),0)"
TargetRng.Formula2 = Replace(PATTERN, _
"$", StartCell.Parent.Name & "!" & StartCell.Address(False, False))
'b) optional overwriting of formulae
'TargetRng = TargetRng.Value
'c) display maximum result
MsgBox Application.Max(TargetRng)
End Sub
Hint: You can even shorten code as follows if you want to include the fully qualified workbook + worksheet reference in the formula assignment. Just use the additional argument External:=True in .Address (resulting e.g. in something like '[Test.xlsm]Sheet1'!A2):
TargetRng.Formula2 = Replace(PATTERN, _
"$", StartCell.Address(False, False, External:=True))
Possible Example call
With Sheet1
CountSubstrings .Range("A2"), .Range("D2:D5")
End With
Further link
C.f. JvdV's encyclopaedia-like site demonstrating the various possibilities to use FilterXML()
Brilliant answer by VBasic2008. I thought I would look at it purely as a coding exercise for myself. Alternative below provided for interest only.
Option Explicit
Sub CountMaxNames()
Dim arr1(), i, j, count As Long, tally As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("leasing")
arr1 = ws.Range("O1:O" & ws.Range("O" & Rows.count).End(xlUp).Row)
count = 0: tally = 0
For Each i In arr1
For j = 1 To Len(i)
If Mid(i, j, 1) = "|" Then count = count + 1
Next j
count = count + 1
If count >= tally Then tally = count
count = 0
Next i
MsgBox "Maximum number of names in one cell is " & tally
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 have a basic userform and need the one textbox to increment the number on the Add/next command, which I get right until you at the "PO" prefix.
I am doing a basic PO entry userform that adds info into the "Entries" sheet. The PO number has a "PO" prefix when clicking the add command I am trying to get the number to increment.
Dim currentrow As Long
Dim NextNum As Long
Dim prefix As String
Dim i As Long
Private Sub frmPurchaseOrder_Initialize()
currentrow = 2
End Sub
Private Sub cmdAdd_Click()
Dim num As Integer
'to check the last filled row
lastrow = ThisWorkbook.Worksheets("Entries").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Entries").Cells(lastrow + 1, 1).value = txtDocNo.Text
ThisWorkbook.Worksheets("Entries").Cells(lastrow + 1, 2).value = txtLineNumber.Text
ThisWorkbook.Worksheets("Entries").Cells(lastrow + 1, 3).value = txtDocType.Text
'next one
Me.txtDocType = "PO"
Me.txtLine = Me.txtLine + 1
End Sub
Private Sub UserForm_Initialize()
currentrow = 2
Me.txtInvoiceDate = Date
Me.txtDocType = "PO"
Me.txtLine = "1"
Me.txtDocNo = Application.WorksheetFunction.max(Range("DocNoList")) + 1
End Sub
The DocNo is in the first column on the entries sheet, range named "DocNoList"
I would appreciate your help.
Since you have the "PO" prefix in front of all the document numbers the Max function doesn't work. It would seem to be easiest to just access the last row of your data and extract the numeric value from that. Replace this line
Me.txtDocNo = Application.WorksheetFunction.max(Range("DocNoList")) + 1
with
With ThisWorkbook.Worksheets("Entries").Cells(Rows.Count, 1).End(xlUp)
Me.txtDocNo.Value = Me.txtDocType.Value + CInt(Right(.Value2, Len(.Value2) - 2)) + 1
End With
Alternatively:
Dim strDocNo As String
strDocNo = ThisWorkbook.Worksheets("Entries").Cells(Rows.Count, 1).End(xlUp).Value2
Me.txtDocNo.Value = Me.txtDocType.Value + CInt(Right(strDocNo, Len(strDocNo) - 2)) + 1
How do I count only as "2" if the word "apple" show in the same row like row3 and row4 ? The code i need is in Microsoft excel 2010 not vba
Expected Output:
Got very close to figuring out a formula but I'm afraid I bailed and created a UDF instead after getting fed up.
Paste the following into a module in the vba editor (will have to save the file as a .xlsm now as well). This will work for all 2D ranges (i.e. where the count of rows and the count of columns are both greater than 1) a 1D range you can use COUNTIF as stated in the comments above.
Public Function CountStringOccurence(count_text As String, within_range As Range) As Long
Dim arr As Variant
Dim i As Long
' Create array of 1's and 0's (Numerical trues and falses)
arr = Application.Evaluate("--(" & within_range.Parent.Name & "!" & within_range.Address & "=""" & count_text & """)")
' Loop through each row array
For i = LBound(arr, 1) To UBound(arr, 1)
' Get max value in each row and sum (i.e. if there is a True present add it to the total count)
CountStringOccurence = CountStringOccurence + Application.Max(Application.Index(arr, i, 0))
Next i
End Function
and call it using CountStringOccurence(B7,A3:G4)
In the function it first populates an array from the range with 1 if the value in the range matches the string wanted and 0 if it doesn't. It then loops through each row in the array summing the maximum value in the row (i.e. 1 if the value exists and 0 if it doesn't). It then feeds the answer back to the Excel cell
If someone can come up with a formula for it though I'd love to see it.
If you can add an extra column to sheet you can also achieve this doing:
Last column in sheet enter =MAX(--(A3:G3=$B$7)) for each row and then sum this column to get your answer
It may not be the most simple way to do it but here you go:
Public Sub getRowCountOfStringOccurance()
Dim thisRange As Range
Set thisRange = Selection
MsgBox (countStringOccurancesInRows("apple", thisRange))
End Sub
Public Function countStringOccurancesInRows(stringToFind As String, searchRange As Range) As Integer
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim ws As Worksheet
Set ws = wb.ActiveSheet
Dim firstRow As Integer
Dim lastRow As Integer
Dim firstColumn As Integer
Dim lastColumn As Integer
Dim rowOccurances As Integer
rowOccurances = 0
Dim occurances As Integer
occurances = 0
firstRow = searchRange.Rows(1).Row
lastRow = searchRange.Rows.Count + firstRow - 1
firstColumn = searchRange.Columns(1).Column
lastColumn = searchRange.Columns.Count + firstColumn - 1
For thisRow = firstRow To lastRow
For thisColumn = firstColumn To lastColumn
If (ws.Cells(thisRow, thisColumn) = stringToFind) Then
rowOccurances = rowOccurances + 1
End If
Next
If (rowOccurances > 0) Then
occurances = occurances + 1
End If
Next
countStringOccurancesInRows = occurances
End Function
Be aware that I've entered the string for the moment and the range to be searched through has to be selected in the sheet. It will then give a messagebox with the result. While testing I had no issues.
I am trying to cycle through names of customers on one sheet (sheet2), take the corresponding value in column J in sheet1 and then paste next to the customers on the original sheet.
This is my code:
For i = 0 To 9
Dim rowi As Long
rowi = Application.WorksheetFunction.Match((Worksheets("Sheet2").Cells(5 + i, 4)), Worksheets("Sheet1").Range("B:B"), 0)
Crystali = Cells(rowi, 10)
Sheets("Sheet2").Activate
Worksheets("Sheet2").Cells(5 + i, 7) = Crystali
Next i
Can someone help me fix it? I keep getting the error "Unable to get the Match property of Worksheetfunction class"
Thanks in advance.
here short example how to use the 'Match()' function without 'worksheet-function' part like Tim suggests. After the Match function was called just check the result with 'IsError()'.
Option Explicit
Public Sub test()
Dim row_index As Long
Dim match_result As Variant
Dim lookup_value As Variant
Dim lookup_array As Variant
Set lookup_array = Range("Sheet1!B:B")
Const FIRST_ROW As Byte = 5
Const LAST_ROW As Byte = 9
For row_index = FIRST_ROW To LAST_ROW
Set lookup_value = Range("Sheet2!D" & row_index)
match_result = Application.Match(lookup_value, lookup_array, 0)
If Not IsError(match_result) Then
' copy data only if Match function found something
Range("Sheet2!G" & row_index) = Range("Sheet1!J" & match_result)
End If
Next row_index
End Sub