I Have Table like this, where i have to use macro because my table always change Every day (SSAS)
so i have use macro to filter automatically,
I am able to sum Amount based on same Vendorname, PONuber and Date on Column E (Subtotal).
and then filter to show Subtotal AMount >500
I want to show only row >500 (Column E), and pop up message to count PONumber (Column B) how many Unique PO Number (Only Visible Row to count)
i've been stuck how to count only Visible Unique PO Number and show it on Pop Up message
this is my Macro
Sub FilterCOunt_Click()
Dim Condition As Variant
Dim AVal As Variant
Dim LastRow As Long
Dim Hide, popup As Long
Dim message As String
Dim sht As Worksheet
'----------------------------
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
'---------------------------
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
Application.ScreenUpdating = False
Application.StatusBar = False
'------------------
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
Columns("E:Z").EntireColumn.Delete
Range("E:Z").EntireColumn.Insert
Range("E1").Value = "Sub Total >500 "
Set sht = ActiveSheet
LastRow = sht.Range("B" & Rows.Count).End(xlUp).Row
'-------------------
For i = 2 To LastRow ' with last row count =SUMIFS(I:I,A:A,A8,B:B,B8,C:C,C8)
AVal = "A" & i
BVal = "B" & i
CVal = "C" & i
Worksheets("Sheet3").Range("E" & i).Formula = "=SUMIFS(D:D,A:A," & AVal & ",B:B," & BVal & ",C:C," & CVal & ")"
Next i
With sht.Range("E1:E" & LastRow)
.AutoFilter
.AutoFilter field:=1, Criteria1:=">=500"
End With
'----------Count Pop UP
Dim CountPO As Long
Range("G1").FormulaArray = "=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"",MATCH(""&B2:B22,B2:B22&"",0))),ROW(B2:B22)- ROW(B2)+1),1))"
MsgBox "We Found " & CountPO & " PO Open(s)", _
vbInformation, "PO Found"
End Sub
and this is the formula to count it
{=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"",MATCH("~"&B2:B22,B2:B22&"",0))),ROW(B2:B22)-ROW(B2)+1),1))}
If you are pulling from a Database via SSAS you can use Power Query to link to your SSAS DataModel to Excel and you can insert a Calculated Measure in Dax from there with DistinctCount.
Count:=Calculate(DistinctCount(TableName[PONumber]),TableName[Amount]>500)
Alternatively if you want total insights on your specified issue you can add a measured column and then you can use Power Pivot to filter for your criteria live on refresh to the data model, completely negating the need for VBA entirely.
Incidentally it is pertinent to remember VBA is the sledge hammer of solutions please use the DataModel Tools before you ever think of a macro solution remember, VBA is an Application Programming Language and many IT Security Systems will disable it because it opens the system up for malware, you can literally change any file or program in VBA including calling delete system files
Meanwhile having a set DataModel in a locked file that requires user access behind LAN security is easily more secure than allowing your computer to have open programatic access.
This is an alternative formula (which doesn't require any filtering)
=SUM(--(FREQUENCY(IF(B2:B20>500,MATCH(A2:A20,A2:A20,0)),ROW(A2:A20)-ROW(A2)+1)>0))
It's an array formula so using VBA
Range("E1").FormulaArray = "=SUM(--(FREQUENCY(IF(B2:B20>500,MATCH(A2:A20,A2:A20,0)),ROW(A2:A20)-ROW(A2)+1)>0))"
A formula for your cell E2, which is not an array formula, is
=SUMPRODUCT((B2=B$2:B$23)*(A2=A$2:A$23)*(D$2:D$23))
Copy it down, as usual.
See here for why not using an array formula (if you have an alternative).
I am not certain this solves your question, as I did not fully understand it.
You can use the following code. I have implemented Collection to get the unique count.
This will count the unique rows in B column where value in E column > 500.
Private Sub GetUniqueCount() AS Variant
Dim Test As New Collection
Dim rng As Range
For i = 2 To 6 'Replace 6 with last row(without filtration)
Value = Cells(i, "B").Value
check = Contains(Test, Value)
If Cells(i, "E").Value > 500 And Not check And Len(Value) > 0 Then
Test.Add Value, CStr(Value)
End If
Next i
GetUniqueCount = Test.count
End Sub
'Function to check if the value exists in Collection or not
Public Function Contains(col As Collection, key As Variant) As Boolean
Dim obj As Variant
On Error GoTo err
Contains = True
obj = col(key)
Exit Function
err:
Contains = False
End Function
Step 1: Post my code to a new module.
Step 2: Bind you button to the macro named "filterAndCount"
Step 3: Click the buton and rejoice :-)
Code description:
1) The code loops all the rows in the table.
2) First it checks if the Sub Total is above the limit (500).
3) If equal or below it hides the row and moves on to the next row.
4) If above it checks if the value already exists in the array values above.
5) If it does not exists then the value is added to the array.
6) When all rows have been looped only rows with a Sub Total above the limit is visible.
7) Only the unique and visible PO Numbers have been added to the array.
8) The number of values in the array is dispayed in a message box.
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Double
Dim n As Double
Dim subTotalLimit As Double
Dim arr() As String
Sub filterAndCount()
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
i = 2
subTotalLimit = 500
n = 0
ReDim arr(0 To 0) As String
arr(0) = 0
ws.Columns("E:Z").EntireColumn.Delete
ws.Range("E:Z").EntireColumn.Insert
ws.Range("E1").Value = "Sub Total >500 "
Do While ws.Range("B" & i) <> ""
ws.Range("E" & i).Formula = "=SUMIFS(D:D,A:A,A" & i & ",B:B,B" & i & ",C:C,C" & i & ")"
If ws.Range("E" & i) < subTotalLimit Then
ws.Range("B" & i).EntireRow.Hidden = True
Else
If Not IsNumeric(Application.Match(Range("B" & i).Text, arr(), 0)) Then
arr(n) = Range("B" & i).Value
n = UBound(arr) + 1
ReDim Preserve arr(0 To n) As String
arr(n) = 0
End If
End If
i = i + 1
Loop
MsgBox UBound(arr)
End Sub
Use 2 Dictionary Objects, one for totals and one for unique PO's
Sub filterCOunt()
Const LIMIT = 500
Dim wb As Workbook, ws As Worksheet
Dim iRow As Long, iLastRow As Long, amount As Single
Dim sVendor As String, sPO As String, msg As String, sKey As String
Dim dictPO As Object, dictTotal As Object
Set dictPO = CreateObject("Scripting.Dictionary")
Set dictTotal = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
Set ws = ActiveSheet
iLastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
' first pass to total by po and vendor
For iRow = 2 To iLastRow
sVendor = Trim(ws.Cells(iRow, 1))
sPO = Trim(ws.Cells(iRow, 2))
amount = CSng(ws.Cells(iRow, 4))
sKey = sVendor & "_" & sPO
' sub total
If dictTotal.exists(sKey) Then
dictTotal(sKey) = dictTotal(sKey) + amount
Else
dictTotal.Add sKey, amount
End If
Next
' second pass for PO numbers
For iRow = 2 To iLastRow
sVendor = Trim(ws.Cells(iRow, 1))
sPO = Trim(ws.Cells(iRow, 2))
sKey = sVendor & "_" & sPO
' sub total
ws.Cells(iRow, 5) = dictTotal(sKey)
If dictTotal(sKey) > LIMIT Then
If Not dictPO.exists(sPO) Then
dictPO.Add sPO, iRow
End If
End If
Next
' filter
With ws.Range("E1:E" & iLastRow)
.AutoFilter
.AutoFilter field:=1, Criteria1:=">=" & LIMIT
End With
msg = "No of open PO's = " & dictPO.Count
MsgBox msg, vbInformation
End Sub
First, for your code Count Pop UP to work, let's change all from "" to """"
Second, to be able to notify a Unique PO Number and show it on Pop Up message, you must call the value received from cell G1, or, safer, use evaluate to get the result of this expression.
Your code will probably work now
'Dim CountPO As Long
Range("G1").FormulaArray = "=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"""",MATCH(""""&B2:B22,B2:B22&"""",0))),ROW(B2:B22)- ROW(B2)+1),1))"
MsgBox "We Found " & [g1].Value2 & " PO Open(s)", vbInformation, "PO Found"
however, your formula only counts all unique values including less than 500, in addition it is quite long. You can replace it using the shorter formula like the following code:
Dim formula_string As String
formula_string = "=SUMPRODUCT((B2:B22>3)*(C2:C22<>"""")/COUNTIF(B2:B22,B2:B22&""""))"
MsgBox "We Found " & Application.Evaluate(formula_string) & " PO Open(s)", vbInformation, "PO Found"
Hope it helps!
My goal is to be able to "translate" for lack of a better term; each cell in a sheet range into VBA.
This means I can instantly take an existing workbook and produce VBA to recreate it.
So I put this UDF together. It shows a cell as it would appear in VBA. R1C1 format
Function showformula(rng As Range)
If rng.HasArray = True Then
showformula = "{" & rng.Formula & "}"
Else
showformula = "Sheets(""" & ActiveSheet.Name & """). Range(""" & rng.Address & """)" & ".FormulaR1C1 = " & """" & rng.FormulaR1C1 & """"
End If
End Function
So 1)show a user select box for specifying a range. Then Click Proceed and 2) the above UDF reads for every cell in the specified range and 3) prints each cell's result on a new line in cell ZZ.
1 is easy enough to googlefu
but 2) & 3) I do not know how I would write it
https://www.reddit.com/r/excel/comments/brndla/how_to_apply_formula_to_every_cell_in_range_and/
Solution Occurred here
Sub BuildList()
Dim c As Range
Dim rngInput As Range
Dim rngOutput As Range
Dim i As Long
'Ask our user for stuff
Set rngInput = Application.InputBox("What cells do you want to read?", "Input", , , , , , 8)
Set rngOutput = Application.InputBox("Where do you want output to go?", "Output", , , , , , 8)
Application.ScreenUpdating = False
'Write the answers
For Each c In rngInput.Cells
rngOutput.Cells(1).Offset(i).Value = ShowFormula(c)
i = i + 1
Next c
Application.ScreenUpdating = True
End Sub
Function ShowFormula(rng As Range)
If rng.HasArray = True Then
ShowFormula = "{" & rng.Formula & "}"
Else
ShowFormula = "Sheets(""" & ActiveSheet.Name & """). Range(""" & rng.Address & """)" & ".FormulaR1C1 = " & """" & rng.FormulaR1C1 & """"
End If
End Function
I am trying to clean an excel dataset provided to me using VBA in the most efficient way possible. I want to compare row values (# may vary) of 3 columns within a worksheet range, if the row values are the same for all 3 columns, then i want the values of the same rows but different columns copied into one cell.
Sample Set: red should be copied into one cell:
Expectation with black removed and red in one cell
Ultimate Want
Before/ After Expectation
In the future, SO questions should be about specific issues you are having, not a general question.
Here is a VBA function that will:
Go through each cell, until it finds an empty cell. We will assume once an empty cell is found we are at the end of your data set.
Check if any of the first three columns have changed their data from the previous cell. If they have, this is our new 'working row'. The row where we will consolidate your dataset into.
For each row, add its value from the data set column to the 'working row', unless it already exists in that row.
Once finished, go back and delete empty cells.
Here's the subroutine:
Sub clean_dataset()
Dim sh As Worksheet
Dim rw As Range
Dim workingRow As Integer
Dim col1Value As String
Dim col2Value As String
Dim col3Value As String
Dim rowCount As Integer
workingRow = 1
'Iterate through all rows on the sheet. Stop if we get to an empty row.
Set sh = ActiveSheet
For Each rw In sh.Rows
' Exit if we get to an emptry row.
If sh.Cells(rw.Row, 1).Value = "" Then
Exit For
End If
' Check if our three columns to watch have changed value. If they have, we should be in a new 'working row'
If rw.Row > 1 Then
If (Range("A" & rw.Row).Value <> Range("A" & rw.Row - 1).Value) Or (Range("B" & rw.Row).Value <> Range("B" & rw.Row - 1).Value) Or (Range("C" & rw.Row).Value <> Range("C" & rw.Row - 1).Value) Then
workingRow = rw.Row
End If
End If
' Get the values in the current row from the dataset we are trying to consolidate.
col1Value = Range("D" & rw.Row).Value
col2Value = Range("E" & rw.Row).Value
col3Value = Range("F" & rw.Row).Value
' Add the values to the working row cells, if they do not already exist
If InStr(Range("D" & workingRow).Value, col1Value) = 0 Then
Range("D" & workingRow) = Range("D" & workingRow).Value & vbLf & col1Value
End If
If InStr(Range("E" & workingRow).Value, col2Value) = 0 Then
Range("E" & workingRow) = Range("E" & workingRow).Value & vbLf & col2Value
End If
If InStr(Range("F" & workingRow).Value, col3Value) = 0 Then
Range("F" & workingRow) = Range("F" & workingRow).Value & vbLf & col3Value
End If
' As long as we are not in the working row, delete the values
If rw.Row <> workingRow Then
Range("D" & rw.Row) = vbNullString
Range("E" & rw.Row) = vbNullString
Range("F" & rw.Row) = vbNullString
End If
rowCount = rw.Row
Next rw
' End of for each
' Go back through, and delete any rows that do not have values in column D
For iter = rowCount To 1 Step -1
' If all three columns are blank, delete the row.
If Range("D" & iter).Value = vbNullString Then
sh.Rows(iter).Delete
End If
Next
End Sub
Hope this helps.
After quite a bit of searching I was able to finally find this very applicable post as my issue is similar to the OP.
I'm working with three sheets where Sheet 1 is the source, Sheet 2 is a check sheet and Sheet 3 is where I would be pasting/cleaning up my data from Sheet 2.
In Sheet1, I copy the value in Col C and filter it in Sheet2 - Col C and for each company in Col J, I need to check the volume in Col K and if volume is >/= 1, the row needs to be copy/pasted into Sheet 3 while consolidating the corresponding unique values in each cell of the row and removing duplicates and summing the values in col K. The third sheet is the expected sheet. Thanks for your help if possible.
I'm trying to build a formula that can lookup multiple ISO country codes separated by comma contained in one cell (Cell A2, Image 1) with a reference to a list of country codes and education scoring (Columns F and G, Image 1). Then return the average of the scores of all countries on cell B2. does anyone know if I can build a formula to handle that?
I didn't think you could do this with cell formula, but then I saw this post and came up with this:
=AVERAGE(IF(ISNA(MATCH($F$2:$F$99, TRIM(MID(SUBSTITUTE(A2,",",REPT(" ",99)),(ROW(OFFSET($A$1,,,LEN(A2)-LEN(SUBSTITUTE(A2,",",""))+1))-1)*99+((ROW(OFFSET($A$1,,,LEN(A2)-LEN(SUBSTITUTE(A2,",",""))+1)))=1),99)), 0)), "", $G$2:$G$99 ))
Try pasting into cell B2 as an array formula (Ctrl + Shift + Enter) and fill-down... And don't ask me how it works.
You could try VBA:
Option Explicit
Sub test()
Dim i As Long
Dim strCode As String, strScore As String
Dim rngVlookup As Range
Dim Code As Variant
With ThisWorkbook.Worksheets("Sheet1")
Set rngVlookup = .Range("F2:G34")
For i = 2 To 3
strCode = ""
strScore = ""
strCode = .Range("A" & i).Value
For Each Code In Split(strCode, ",")
If strScore = "" Then
On Error Resume Next
strScore = Application.WorksheetFunction.VLookup(Trim(Code), rngVlookup, 2, False)
Else
On Error Resume Next
strScore = strScore & ", " & Application.WorksheetFunction.VLookup(Trim(Code), rngVlookup, 2, False)
End If
Next Code
With .Range("B" & i)
.Value = strScore
.NumberFormat = "0.000000"
End With
Next i
End With
End Sub
so i have Sheet1 that is use to contain the list of my inventory data. what i want to do is in another sheet(Sheet2). i can search my Sheet1 data and display the data there ( for example when i type cheetos, only the cheetos item got display ). Help me guys, using VBA is okay or other method is also fine.
If your results don't have to be on a different sheet, you could just convert your data to a Table. Select Cells A1:D8 and click on Insert -> Table. Make sure "My table has headers" is clicked and voila!
Once formatted as a table, you can filter Product ID however you need.
If you do need to show these results in another sheet, VBA would be my go-to solution. Maybe something like this:
Public Sub FilterResults()
Dim findText As String
Dim lastRow As Long
Dim foundRow As Long
Dim i As Long
'If there's nothing to search for, then just stop the sub
findText = LCase(Worksheets("Sheet2").Range("D4"))
If findText = "" Then Exit Sub
'Clear any old search results
lastRow = Worksheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Row
If lastRow > 5 Then
For i = 6 To lastRow
Worksheets("Sheet2").Range("C" & i).ClearContents
Worksheets("Sheet2").Range("D" & i).ClearContents
Worksheets("Sheet2").Range("E" & i).ClearContents
Worksheets("Sheet2").Range("F" & i).ClearContents
Next i
End If
'Start looking for new results
lastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
foundRow = 6
For i = 2 To lastRow
If InStr(1, LCase(Worksheets("Sheet1").Range("B" & i)), findText) <> 0 Then
Worksheets("Sheet2").Range("C" & foundRow) = Worksheets("Sheet1").Range("A" & i)
Worksheets("Sheet2").Range("D" & foundRow) = Worksheets("Sheet1").Range("B" & i)
Worksheets("Sheet2").Range("E" & foundRow) = Worksheets("Sheet1").Range("C" & i)
Worksheets("Sheet2").Range("F" & foundRow) = Worksheets("Sheet1").Range("D" & i)
foundRow = foundRow + 1
End If
Next i
'If no results were found, then open a pop-up that notifies the user
If foundRow = 6 Then MsgBox "No Results Found", vbCritical + vbOKOnly
End Sub
I would recommend avoiding VBA for this process as it can be done easily with excel's functions. If you would like to do it via VBA one could just loop through the list of products and find a key word, adding it to an array if the "Cheetos" is contained in the specific cell value using a wildcard like so:
This could be modified to run upon the change of the D4 cell if needed, and of course some modifications could be done to ensure that formatting etc can be done to your liking.
Sub test()
Dim wb As Workbook
Dim rng As Range, cell As Range
Dim s_key As String, s_find() As String
Dim i As Long
Set wb = Application.ThisWorkbook
Set rng = wb.Sheets("Sheet1").Range("B2:B8")
s_key = wb.Sheets("Sheet2").Range("D4").Value
wb.sheets("Sheet2").Range("C6:F9999").clearcontents
i = 0
For Each cell In rng
If cell.Value Like "*" & s_key & "*" Then
ReDim Preserve s_find(3, i)
s_find(0, i) = cell.Offset(0, -1).Value
s_find(1, i) = cell.Value
s_find(2, i) = cell.Offset(0, 1).Value
s_find(3, i) = cell.Offset(0, 2).Value
i = i + 1
End If
Next cell
wb.Sheets("Sheet2").Range("C6:F" & 5 + i).Value = Application.WorksheetFunction.Transpose(s_find)
End Sub