I am not able to take the reference from column AB and AC given in sheet ("UPDATER") to sheet("Historical_vol"), can anyone please confirm what am i doing wrong here ?
Sub historical_vol()
Application.ScreenUpdating = True
'This will help to watch the status bar update
Application.Calculation = xlCalculationManual
Dim wb As Workbook, uPd As Worksheet, hV As Worksheet
Dim lr As Long, cl As Range
Set wb = ThisWorkbook
Set uPd = wb.Sheets("UPDATER")
Set hV = wb.Sheets("Historical_vol")
uPd.Activate
uPd.Range("AD4:AG4", Range("AD4").End(xlDown)).Clear
lr = uPd.Cells(Rows.Count, "AB").End(xlUp).Row
i = 0
For i = 4 To lr
hV.Range("A9:B9").Value = uPd.Range("AB" & i & ":AC" & i).Value
hV.Calculate
DoEvents
uPd.Range("AD" & i & ":AG" & i).Value = hV.Range("C9:F9").Value
Application.StatusBar = i - 3 & " / " & lr - 3
'View on status bar number of records completed out of total records (lr-3)
Next i
Application.Calculation = xlCalculationAutomatic
End Sub
UPDATER SHEET
HISTORICAL_VOL SHEET
Try changing the line
For Each cl In uPd.Range("AB4:AC4" & lr)
to
For Each cl In uPd.Range("AB4:AC" & lr).Rows
and the line
cl.Offset(0, 2).Resize(1, 4).Value = hV.Range("C9:F9").Value
to
cl.Offset(0, 2).Resize(1, 3).Value = hV.Range("C9:F9").Value
I keep getting a type mismatch error on the below code (indicated next to line), whats interesting is that the macro was running but when I emailed it to myself on another computer it broke. Any idea how to fix this?
To give background, the macro is is for a user form that logs issues into different tabs (depending on what the issue is). When the issue is marked as complete, the issue is moved into the "5. Complete and Verified" tab, assigning the row a number, and adding in a column stating how many days it took to complete the issue. When the issue is moved out of the source tab, it is copied, deleted, then added into the 5. Complete and Verified tab.
Option Explicit
Sub Complete()
Dim sourceWS As Worksheet
Set sourceWS = ActiveSheet
Dim destWS As Worksheet
Set destWS = ThisWorkbook.Worksheets("5. Complete & Verified")
Dim RowCountS, RowCountD As Long
Dim intLastRowSrc As Long
RowCountS = ActiveSheet.Rows.Count
intLastRowSrc = sourceWS.Cells(RowCountS, 1).End(xlUp) + 1'Type Mistmatch
Dim intLastRowSDes As Long
RowCountD = Worksheets("5. Complete & Verified").Rows.Count
intLastRowSDes = destWS.Cells(RowCountD, 2).End(xlUp) + 1 'Type Mismatch
Dim r As Long
Dim iRow2 As Long
iRow2 = Application.WorksheetFunction.CountA(Sheets("5. Complete & Verified").Range("B:B")) + 1
Dim iRow3 As Long
iRow3 = Application.WorksheetFunction.CountA(sourceWS.Range("A:A")) + 1
Dim LastRow4 As Long
Dim LastRow5 As Long
For r = intLastRowSrc To 2 Step -1
If sourceWS.Cells(r, "R") = "Complete & Verified" Then
intLastRowSDes = destWS.Cells(RowCountD, 2).End(xlUp) + 2
destWS.Range("C" & intLastRowSDes & ":S" & intLastRowSDes).Value = sourceWS.Range("B" & r & ":R" & r).Value
sourceWS.Rows(r).Delete
destWS.Cells(intLastRowSDes, 1) = sourceWS.Name ' Adding tab name as the Payer
destWS.Cells(iRow2, 2) = iRow2 - 1 ' Numbering the rows in order instead of copying number from payer tab
'Adding in Column for Days to Complete
Worksheets("5. Complete & Verified").Cells(2, 20) = "=IF(RC[-3]="""",0,RC[-3]-RC[-9])"
LastRow5 = Worksheets("5. Complete & Verified").Range("A1").End(xlDown).Row 'last row filled number row number not cell value 'need to copy before pasting
Worksheets("5. Complete & Verified").Range("T2").Copy
Worksheets("5. Complete & Verified").Range("T2" & ":" & "T" & LastRow5).PasteSpecial (xlPasteFormulas) 'paste formulas
Worksheets("5. Complete & Verified").Range("A1") = "Payor"
Worksheets("5. Complete & Verified").Range("A1") = "Payor"
Worksheets("5. Complete & Verified").Activate
Range("A1").Select
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
'Renumbering the No. Column on the Payer Tab
sourceWS.Activate
If IsEmpty(sourceWS.Range("A2")) = False Then
LastRow4 = Range("A1").End(xlDown).Row 'last row filled number row number not cell value 'need to copy before pasting
If (LastRow4 = 2) Then
sourceWS.Range("A2") = 1
Else
sourceWS.Range("A2") = "=ROW()-1"
sourceWS.Range("A2").Copy
sourceWS.Range("A2" & ":" & "A" & LastRow4).FillDown 'paste formula
End If
sourceWS.Calculate
sourceWS.Range("A2" & ":" & "A" & LastRow4).Copy
sourceWS.Range("A2" & ":" & "A" & LastRow4).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A2").Select
End If
End If
Next
Exit Sub
End Sub
sourceWS.Cells(RowCountS, 1).End(xlUp) returns a Range Reference and you can't add a number to a Range. Try: sourceWS.Cells(RowCountS, 1).End(xlUp).Row() + 1 and you should have a valid row number.
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!
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
Im having trouble deleting Rows when running the code not in debug mode. I put stars next to the line giving me a problem. Works in debug mode but not normally running the code. Any help? I have tried using doevent but in the beginning of the for loop but that didnt work.
Public Sub ItemUpdate(ByVal startRow As Integer, ByVal endRow As Integer, ByVal itemCol As String, ByVal statusCol As String, ByVal manuPNCol As String)
Dim orgSheet As Worksheet
Dim commonSheet As Worksheet
Dim partDesCol As String
Dim partDes As String
Dim vendorColNumber As Integer
Dim vendorColLetter As String
Dim manuPN As String
Dim counter As Integer
Dim replaceRnge As Range
Set orgSheet = ThisWorkbook.ActiveSheet
partDesCol = FindPartDesCol()
Set commonSheet = ThisWorkbook.Worksheets("Common Equipment")
For counter = startRow To endRow
'Get part description value
partDes = Range(partDesCol & counter).Value
'Delete row of empty cells if there is any
If partDes = "" Then
'deleteing empty row
orgSheet.Rows(counter).Delete '************************** Only works in
debug mode.
endRow = endRow - 1
If counter < endRow Then
counter = counter - 1
Else
Exit For
End If
Else
manuPN = Range(manuPNCol & counter).Value
'Search for user part in common sheet
Set rangeFind = commonSheet.Range("1:200").Find(partDes, lookat:=xlWhole)
If rangeFind Is Nothing Or partDes = "" Then
Debug.Print "Part " & partDes & " not found in Common Equipment"
'MsgBox "Part " & partDes & " not found in Common Equipment"
'Now check if manuPN is in common equipment
Set rangeFind = commonSheet.Range("1:200").Find(manuPN, lookat:=xlWhole)
If rangeFind Is Nothing Or partDes = "" Then
Debug.Print "PartNumber " & manuPN & " not found in Common Equipment"
'Now check if vendor value of item is empty
'Get vendor col
vendorCol = FindSearchCol()
If orgSheet.Range(vendorCol & counter).Value = "" Then
'Copy and paste manufact. data to vendor
'converting from letter column to number and visa versa
vendorColNumber = Range(vendorCol & 1).Column
ManuColTemp = vendorColNumber - 2
ManuPNColTemp = vendorColNumber - 1
VendorPNColTemp = vendorColNumber + 1
ManuCol = Split(Cells(1, ManuColTemp).Address(True, False), "$")(0)
manuPNCol = Split(Cells(1, ManuPNColTemp).Address(True, False), "$")(0)
VendorPNCol = Split(Cells(1, VendorPNColTemp).Address(True, False), "$")
(0)
orgSheet.Range(ManuCol & counter & ":" & manuPNCol & counter).Copy Range(vendorCol & counter & ":" & VendorPNCol & counter)
End If
Else
'Copy new data from common equipment and paste in place of old data
'Get value of status
If statusCol <> "error" Then
orderStatus = orgSheet.Range(statusCol & counter).Value
End If
commonSheet.Rows(rangeFind.Row).EntireRow.Copy
orgSheet.Range(itemCol & counter).PasteSpecial xlPasteValues
If statusCol <> "error" Then
orgSheet.Range(statusCol & counter).Value = orderStatus
End If
End If
Else
'Copy new data from common equipment and paste in place of old data
'Get value of status
If statusCol <> "error" Then
orderStatus = orgSheet.Range(statusCol & counter).Value
End If
commonSheet.Rows(rangeFind.Row).EntireRow.Copy
orgSheet.Range(itemCol & counter).PasteSpecial xlPasteValues
If statusCol <> "error" Then
orgSheet.Range(statusCol & counter).Value = orderStatus
End If
End If
End If
Next counter
'call renumber item numbers
Call NumberItems(0, 0, 0, False)
End Sub
Most likely, you need to step backwards through your range. When you step forward, as you are doing, the counter will skip a row whenever you delete a row:
For counter = startRow To endRow
Change to
For counter = endRow To startRow Step -1
Also, you should declare endRow and startRow as data type Long. The range of Integer will not cover all the rows in an Excel worksheet; and also VBA is said to convert Integers to Longs when doing the math anyway.