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.
Related
I am trying to write a VBA code where I want to populate DATA from a worksheet Range A to AQ spanning over multiple Rows. AQ contains Value "Open" or "Closed". I want to get the rows where AQ value is closed. I tried using the AutoFilter. This is working fine to an extent. But I have to use 2 For loops. One for Each Row and another for Each Column to populate Row wise, column by column into the list box
My Code as follows:
Note : Actual contents start from 6th Row where 6 contains the headers and data starts from 7th Row
Dim i As Long
Dim rowRange As Range
Dim AllData(1 To 1000, 1 To 43) As String
lstRecords.ColumnCount = 43
Set shDSR = mydata1.Sheets("DSR")
last_Row = shDSR.Cells(Rows.Count, 1).End(xlUp).Row
shDSR.AutoFilterMode = False
shDSR.Range("A6:AQ" & last_Row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = shDSR.Range("A6:AQ" & last_Row).SpecialCells(xlCellTypeVisible)
Dim filtrRow() As String
Dim rowCnt As Long
'Me.lstRecords.Clear
rowCnt = 0
If rng.Count > 0 Then
Me.lstRecords.Clear
Me.lstRecords.ColumnCount = rng.Columns.Count
For Each Row In rng.Rows
Me.lstRecords.AddItem
rowCnt = rowCnt +1
filterRow = Range(Row.Address)
'Me.lstRecords.List() = filterRow ''This throws error Type Mismatch so not using
For i = 1 To Row.Columns.Count
AllData(rowCnt, i) = Row.Cells(1, i).Value ''Move to Array
Me.lstRecords.List(rowCnt - 1, i - 1) = filterRow(1, i)'Buggy error when i = 11
Next
Next
'' Following segment works. Add data to Array and then populate ListBox from Array
Me.lstRecords.List() = AllData
Else
MsgBox "No data matches the filter criteria."
End If
Above Code has both approaches
a) Trying to load directly from excel Range (actually using filterRow, but can also directly use range with same issue). But, this approach stops always when i=11 with Invalid property error. I tried changing the data contents etc still same issue
Another Issue when Not taking the array based approach, only one line is added, so in affect only last line is available in the list box
b) Using the AllData array. I load all the row data (matching criteria) into the array and finally populate the listbox from array. THIS WORKS. But I do not like this approach
Can some one please point out where it is going wrong.
Thanks in advance
Problem is that filters create a non contiguous range consisting of areas which you have to iterate separately.
Option Explicit
Sub demo()
Dim mydata1 As Workbook, shDSR As Worksheet
Dim rng As Range, a As Range, r As Range
Dim last_row As Long, n As Long
Dim i As Long, rowCnt As Long
Dim ListData() As String
' change this
Set mydata1 = ThisWorkbook
Set shDSR = mydata1.Sheets("DSR")
With shDSR
.AutoFilterMode = False
last_row = .Cells(.Rows.Count, "AQ").End(xlUp).Row
.Range("A6:AQ" & last_row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = .Range("A6:AQ" & last_row).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
' clear listbox
With Me.lstRecords
.Clear
.ColumnCount = rng.Columns.Count
End With
'iterate areas and rows to count visible rows
For Each a In rng.Areas
n = n + a.Rows.Count
Next
rowCnt = 0
If n > 1 Then
' size array
ReDim ListData(1 To n, 1 To rng.Columns.Count)
' fill array
For Each a In rng.Areas
For Each r In a.Rows
rowCnt = rowCnt + 1
For i = 1 To UBound(ListData, 2)
ListData(rowCnt, i) = r.Cells(1, i).Value ''Move to Array
Next
Next
Next
' populate ListBox from Array
Me.lstRecords.List() = ListData
Else
MsgBox "No data matches the filter criteria."
End If
End Sub
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
All -
I have a 2 sheet excel.
Sheet 1 is three columns (name, date, value)
Sheet 2 is name.
I want to write a VBA script that displays all of Sheet 1 data that does NOT have any of the name field listed in Sheet 2 anywhere in sheet 1 (name can appear in different columns so ideally it would search all cells in Sheet 1) to appear in sheet 3
See the sample image for a rough idea of what I"m hoping to accomplish. I have searched but have not had luck.
If you have Excel 365 you can use the Dynamic Array formulas
=LET(Names,FILTER(Sheet1!$C:$E,Sheet1!$C:$C<>""),FILTER(Names,ISERROR(MATCH(INDEX(Names,,1),Sheet2!$G:$G,0))))
Example:
Data (Sheet1)
Exclusion List (Sheet2)
Result
Note: this excludes the headers because the header label Name is present in both the Data column and the Exclusion column so be sure to maintain that
Without Excel 365. I'd recommend a UDF
Function FilterList(ByVal Data As Range, ByVal Exclusion As Range) As Variant
Dim Res As Variant
Dim Dat As Variant
Dim Excl As Variant
Dim rw As Long
Dim idx As Long
Dim cl As Long
Dim ExcludeIt As Variant
Dim Cols As Long
Dim TopRow As Long
ReDim Res(1 To Application.Caller.Rows.Count, 1 To Application.Caller.Columns.Count)
If IsEmpty(Data.Cells(1, 1)) Then
TopRow = Data.Cells(1, 1).End(xlDown).Row
Set Data = Data.Resize(Data.Rows.Count - TopRow).Offset(TopRow - 1)
End If
If IsEmpty(Data.Cells(Data.Rows.Count, 1)) Then
Set Data = Data.Resize(Data.Cells(Data.Rows.Count, 1).End(xlUp).Row - Data.Row + 1)
End If
Dat = Data.Value
Excl = Exclusion.Columns(1).Value
Cols = Application.Min(UBound(Dat, 2), UBound(Res, 2))
idx = 0
For rw = 1 To UBound(Dat, 1)
ExcludeIt = Application.Match(Dat(rw, 1), Excl, 0)
If IsError(ExcludeIt) Then
idx = idx + 1
For cl = 1 To Cols
Res(idx, cl) = Dat(rw, cl)
Next
End If
Next
For rw = 1 To UBound(Res, 1)
For cl = IIf(rw <= idx, UBound(Dat, 2) + 1, 1) To UBound(Res, 2)
Res(rw, cl) = vbNullString
Next
Next
FilterList = Res
End Function
Enter it as an Array Formula (complete it with Ctrl+Shift+Enter) in a range large enough to hold the returned data (can be larger), and pass it your input Data range and Exclusion range (both as whole columns)
=FilterList(Sheet1!$C:$E,Sheet2!$G:$G)
Welcome to Stack Overflow!
You did not say where the source table and criteria table begin, or where to place the result of the "anti-filter". I wrote this code on the assumption that they all start at the first cell of the worksheet, A1:
Sub AntiFilter()
Dim aSource As Range, aCriteria As Range, oCell As Range, oTarget As Range, countCells As Long
Set aSource = Worksheets("Sheet1").Range("A1").CurrentRegion
countCells = aSource.Columns.Count
Set aCriteria = Worksheets("Sheet2").Range("A1").CurrentRegion
Set oTarget = Worksheets("Sheet3").Range("A1")
aSource.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=aCriteria, Unique:=False
For Each oCell In Application.Intersect(aSource, aSource.Columns(1))
If oCell.RowHeight < 1 Then
oCell.Resize(1, countCells).Copy Destination:=oTarget
Set oTarget = oTarget.Offset(1, 0)
End If
Next oCell
On Error Resume Next
aSource.Worksheet.ShowAllData
On Error GOTO 0
End Sub
Workbook with macro, test data and examples of selection criteria on Sheet2
If the macro does not work as expected, make sure that you have sheets named Sheet1, Sheet2, and Sheet3 in your workbook, and that the source data range and criteria range start with cells A1. If this is not the case, make the necessary changes to the text of the macro:
I need the row/column combinations marked with an 'X' in my table to be available as three columns in another sheet.
The first column will consist of the cell address,
the second column will have the Row Name, and
the third column will have the Column name of the marked cells.
VLookUp and Index/Match are not helping.
Expected result:
You might get away with something as lazy as, you would change the sheets and the target range srcSht.Range("A1:C5") as appropriate:
Option Explicit
Sub test()
Dim wb As Workbook
Dim srcSht As Worksheet
Dim destSht As Worksheet
Set wb = ThisWorkbook
Set srcSht = wb.Sheets("Sheet1")
Set destSht = wb.Sheets("Sheet2")
Dim targetRange As Range
Set targetRange = srcSht.Range("A1:C5")
Dim loopArray()
loopArray = targetRange.Value2
Dim currRow As Long
Dim currCol As Long
Dim counter As Long
For currRow = LBound(loopArray, 1) To UBound(loopArray, 1)
For currCol = LBound(loopArray, 2) To UBound(loopArray, 2)
If LCase$(loopArray(currRow, currCol) )= "x" Then
counter = counter + 1
destSht.Cells(counter, 1) = targetRange.Cells(currRow, currCol).Address
destSht.Cells(counter, 2) = "Column " & targetRange.Cells(currRow, currCol).Column
destSht.Cells(counter, 3) = "Row " & targetRange.Cells(currRow, currCol).Row
End If
Next currCol
Next currRow
End Sub
This array formula seems to be working for me
=IFERROR(ADDRESS(SMALL(IF($A$1:$C$6="X",ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6)),ROW())/100,MOD(SMALL(IF($A$1:$C$6="X",ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6)),ROW()),100)),"")
but I think could be done more tidily with AGGREGATE.
Also there's no particular reason for multiplying by 100, multiplying by the exact number of columns in the array plus 1 would be better.
Here it is with AGGREGATE
=IFERROR(ADDRESS(AGGREGATE(15,6,(ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6))/($A$1:$C$6="X"),ROW())/100,MOD(AGGREGATE(15,6,(ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6))/($A$1:$C$6="X"),ROW()),100)),"")
EDIT
Here is a more general solution for a 2d range of any size anywhere on the sheet.
For the row:
=IFERROR(INDEX($A$2:$A$7,AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW())/COLUMNS($B$2:$D$7)+1),"")
For the column:
=IFERROR(INDEX($B$1:$D$1,MOD(AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW()),COLUMNS($B$2:$D$7))+1),"")
For the cell address:
=IFERROR(ADDRESS(AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW())/COLUMNS($B$2:$D$7)+ROW($B$2),
MOD(AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW()),COLUMNS($B$2:$D$7))+COLUMN($B$2)),"")
Here's a similar way to get a similar result:
Sub listCells()
Dim rIn As Range, c As Range, rOut As Range
Set rIn = Sheets("Sheet1").Range("B2:D7") 'input range
Set rOut = Sheets("Sheet1").Range("F1") 'first cell for output
For Each c In rIn
If c <> "" Then 'not blank so populate output
Range(rOut, rOut.Offset(, 2)) = Array(c.Address, c.Column - 1, c.Row - 1)
Set rOut = rOut.Offset(1, 0) 'next row
End If
Next c
End Sub
Excel 2010. I am trying to write a macro that could copy a set of data multiple times based on criteria on another sheet, but I've been stuck for a long time. I very much appreciate any help that could be offered to help me solve this problem.
Step 1: In the "Criteria" worksheet, there are three columns in which each row contains a specific combination of data. The first set of combination is "USD, Car".
Criteria worksheet
Step 2: Then the macro will move to the Output worksheet (please refer to the below link for screenshots), and then filter column A and B with the first set of criteria "USD" and "Car" in the "Criteria" worksheet.
Step 3: Afterwards, the macro will copy the filtered data into the last blank row. But the tricky part here is that, the filtered data has to be copied two times (as the "Number of set" column in the "Criteria" tab is 3 in this combination, and it doesn't have to copy the data three times since the filtered data would be treated as the first set of data)
Step4: After the filtered data have been copied, the "Set" column D will need to fill in the corresponding number of set that the rows are in. Therefore, in this 1st example, cell D2 and D8 will have "1" value, cell D14-15 will have "2" value, and cell D16-17 will have "3" value.
Step5: The macro will then move back to the "Criteria" worksheet and continue to based on the 2nd set of combination "USD, Plane" to filter the data in the "Output" worksheet. Again, it will copy the filtered data based on the "Number of set" in the "Criteria" worksheet. This process will continue until all the different combinations in the "Criteria" worksheet have been processed.
Output worksheet
Ok sorry for delay, here is a working version
you just have to add a sheet called "BF" because the autofilter count wasn't working properly so I had to use another sheet
Sub testfct()
Dim ShC As Worksheet
Set ShC = ThisWorkbook.Sheets("Criteria")
Dim EndRow As Integer
EndRow = ShC.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To EndRow
Get_Filtered ShC.Cells(i, 1), ShC.Cells(i, 2), ShC.Cells(i, 3)
Next i
End Sub
Sub Get_Filtered(ByVal FilterF1 As String, ByVal FilterF2 As String, ByVal NumberSetsDisered As Integer)
Dim NbSet As Integer
NbSet = 0
Dim ShF As Worksheet
Set ShF = ThisWorkbook.Sheets("Output")
Dim ColCr1 As Integer
Dim ColCr2 As Integer
Dim ColRef As Integer
ColCr1 = 1
ColCr2 = 2
ColRef = 4
If ShF.AutoFilterMode = True Then ShF.AutoFilterMode = False
Dim RgTotal As String
RgTotal = "$A$1:$" & ColLet(ShF.Cells(1, Columns.Count).End(xlToLeft).Column) & "$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row
ShF.Range(RgTotal).AutoFilter field:=ColCr1, Criteria1:=FilterF1
ShF.Range(RgTotal).AutoFilter field:=ColCr2, Criteria1:=FilterF2
'Erase Header value, fix? or correct at the end?
ShF.AutoFilter.Range.Columns(ColRef).Value = 1
Sheets("BF").Cells.ClearContents
ShF.AutoFilter.Range.Copy Destination:=Sheets("BF").Cells(1, 1)
Dim RgFilt As String
RgFilt = "$A$2:$B" & Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row '+ 1
Dim VR As Integer
'Here was the main issue, the value I got with autofilter was not correct and I couldn't figure out why....
'ShF.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
'Changed it to a buffer sheet to have correct value
VR = Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row - 1
Dim RgDest As String
ShF.AutoFilterMode = False
'Now we need to define Set's number and paste N times
For k = 1 To NumberSetsDisered - 1
'define number set
For j = 1 To VR
ShF.Cells(Rows.Count, 1).End(xlUp).Offset(j, 3) = k + 1
Next j
RgDest = "$A$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":$B$" & (ShF.Cells(Rows.Count, 1).End(xlUp).Row + VR)
Sheets("BF").Range(RgFilt).Copy Destination:=ShF.Range(RgDest)
Next k
ShF.Cells(1, 4) = "Set"
Sheets("BF").Cells.ClearContents
'ShF.AutoFilterMode = False
End Sub
And the function to get column letter using an integer input :
Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function