Okay so I'm a newbie to VBA (actionscript no problem - so not new to coding, just VBA) and have been working trying learn what I can and get some code to work for me. I have a report in Excel. Row 6 is the header, 7 blank and 8 is additional information; the actual data begins on row 9 (B9:D9) downwards. Colum C contains the data I'd like to sort by. As new data gets entered in subsequent rows I'd like for the report to automatically re-sort after I've completed the data entry in D#. (Hope this makes sense)
Is this possible in VBA? Or am I asking too much?
Many thanks.
Here's what I've been working with:
`Private Sub Worksheet_Change(ByVal Target As Range)
Dim CCell As Range
Dim ActiveCellInTable As Boolean
Dim r As Single
Dim Value As Variant
Rows("9:38", "B:E").Select
Set CCell = Target
On Error Resume Next
ActiveCellInTable = (CCell.ListObject.Name = "Table2")
On Error GoTo 0
If ActiveCellInTable = True Then
r = Target.Row - Target.ListObject.Range.Row + 9
For c = 1 To ActiveSheet.ListObjects(CCell.ListObject.Name).Range.Columns.Count
If ActiveSheet.ListObjects(CCell.ListObject.Name).Range.Cells(r, c).Value = "" Then Exit Sub
Next c
With ActiveSheet.ListObjects(CCell.ListObject.Name).Sort
.SortFields.Clear
.SortFields.Add _
Key:=Range("Table2[[#All],[Item number]]"), SortOn:=xlSortOnValues, Order _
:=xlAscending, DataOption:=xlSortNormal
.Apply
End With
End If
End Sub`
Yes it's possible and here's my version of what you're trying to do. 'Worksheet_Change' has to go in Sheet1 code and will get executed each time any cell in the worksheet changes. Just to be safe you should disable events otherwise the code could get interrupted prematurely by a different spreadsheet event:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Integer
Dim entireRange As Range, sortRange As Range
Application.EnableEvents = False
lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).row
If Not Intersect(Target, Me.Range("D9:D" & lastRow)) Is Nothing Then
Set entireRange = Range("B9:D" & lastRow)
Set sortRange = Range("C9:C" & lastRow)
entireRange.Sort Key1:=sortRange, Order1:=xlAscending, Header:=xlNo
End If
Application.EnableEvents = True
End Sub
Related
I have a sheet of almost 100000 rows & column A to Q
I have a code that delete entire rows if column Q has blank cells.
I have tried this code on 4000 rows it is running in 3 minutes but when I take 100000 rows it just processing for hours.
I will be very great full if some help/guide me in speeding up this code.
The code is :
Sub DeleteBlank()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lo As ListObject
set lo = sheets("BOM 6061").ListObjects(1)
Sheets("BOM 6061").Activate
lo.AutoFilter.ShowAllData
lo.range.AutoFilter Field:=17, Criteria1:=""
Application.DisplayAlerts = False
Application.Calculation = xlCalculationAutomatic
lo.DataBodyRange.SpecialCells(xlCellsTypeVisible).Delete
Application.DisplayAlerts = True
lo.AutoFilter.ShowAllData
End Sub
Remove Criteria Rows in an Excel Table Efficiently
In a nutshell, if you don't sort the criteria column, deleting the rows may take 'forever'.
The following will do just that, keeping the initial order of the remaining rows.
Option Explicit
Sub DeleteBlankRows()
Const wsName As String = "BOM 6061"
Const tblIndex As Variant = 1
Const CriteriaColumnNumber As Long = 17
Const Criteria As String = ""
' Reference the table.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(tblIndex)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Remove any filters.
If tbl.ShowAutoFilter Then
If tbl.AutoFilter.FilterMode Then tbl.AutoFilter.ShowAllData
Else
tbl.ShowAutoFilter = True
End If
' Add a helper column and write an ascending integer sequence to it.
Dim lc As ListColumn: Set lc = tbl.ListColumns.Add
lc.DataBodyRange.Value = _
ws.Evaluate("ROW(1:" & lc.DataBodyRange.Rows.Count & ")")
' Sort the criteria column ascending.
With tbl.Sort
.SortFields.Clear
.SortFields.Add2 tbl.ListColumns(CriteriaColumnNumber).Range, _
Order:=xlAscending
.Header = xlYes
.Apply
End With
' AutoFilter.
tbl.Range.AutoFilter Field:=CriteriaColumnNumber, Criteria1:=Criteria
' Reference the filtered (visible) range.
Dim svrg As Range
On Error Resume Next
Set svrg = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Remove the filter.
tbl.AutoFilter.ShowAllData
' Delete the referenced filtered (visible) range.
If Not svrg Is Nothing Then svrg.Delete
' Sort the helper column ascending.
With tbl.Sort
.SortFields.Clear
.SortFields.Add2 lc.Range, Order:=xlAscending
.Header = xlYes
.Apply
.SortFields.Clear
End With
' Delete the helper column.
lc.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
' Inform.
MsgBox "Blanks deleted.", vbInformation
End Sub
I would not use an Autofilter on large data sets as they can take quite a bit of time trying to enumerate the available options before actually filtering the data. The AutoFilter.ShowAllData takes just as much time. For my super simple test dataset, which consisted of 26 columns of 1000000 rows, it took 30+ seconds for each to process.
From what I can tell you are filtering the list to show only the blank items and then deleting the blank rows. Since the filtering is what is causing the delay we could just loop through each row looking at a specific column and if it is blank you can just delete it. Below is an example of how to do this.
**Edit: After testing I found this to be much slower than what you would want. Check out the next example below as it is super fast.
Option Explicit
Sub DeleteBlank()
Application.ScreenUpdating = False
Dim calcType As Integer
Dim rowCount, columnNumToCheck, currow, dataStartRow As Long
Dim WkSht As String
Dim lo As ListObject
WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
columnNumToCheck = 17 'The column number to check for blank cells.
calcType = Application.Calculation
Application.Calculation = xlCalculationManual
Set lo = Sheets(WkSht).ListObjects(1)
rowCount = lo.ListRows.Count
dataStartRow = (lo.DataBodyRange.Row - 1)
For currow = rowCount To 1 Step -1
If Sheets(WkSht).Cells((currow + dataStartRow), columnNumToCheck).Value = "" Then
Call DeleteRows(WkSht, (currow + dataStartRow))
End If
Next currow
Application.Calculation = calcType
Application.ScreenUpdating = True
End Sub
Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)
If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
optionalEndRow = startRow
End If
Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp
End Sub
If you are able to sort your data where the blank cells are all together you could use the below to perform a single delete function remove them all at once. This deleted 70000 rows in a few seconds.
Sub DeleteBlankWithSort()
'Application.ScreenUpdating = False
Dim columnNumToCheck, tableLastRow, lrow As Long
Dim calcType As Integer
Dim WkSht As String
Dim lo As ListObject
WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
columnNumToCheck = 17 'The column number to check for blank cells.
calcType = Application.Calculation
Application.Calculation = xlCalculationManual
Set lo = Sheets(WkSht).ListObjects(1)
tableLastRow = FindLastRow(WkSht, (columnNumToCheck))
With lo.Sort
.SortFields.Clear
.SortFields.Add _
Key:=Range("Table1[[#All],[q]]"), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
lrow = FindLastRow(WkSht, (columnNumToCheck), (tableLastRow))
Call DeleteRows(WkSht, (tableLastRow), (lrow + 1))
Application.Calculation = calcType
Application.ScreenUpdating = True
End Sub
Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)
If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
optionalEndRow = startRow
End If
Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp
End Sub
Private Function FindLastRow(sheetNameIn As String, columnNum As Long, Optional optionalStartRow As Long) As Long
'finds the last row of the column passed in the sheetname passed in
If IsNull(optionalStartRow) Or optionalStartRow = 0 Then
optionalStartRow = 1048576
End If
FindLastRow = Worksheets(sheetNameIn).Range(Cells(optionalStartRow, columnNum).Address).End(xlUp).Row
End Function
I had an simple example of this from a while ago. Advanced filtering is the fastest way to filter in place or to filter and copy in excel/vba. In advanced filtering you usually have your filters listed out in columns/rows and can have as many as you need, use >"" for filtering out blanks on a column, should take no time at all. In my example it might be different as this was used alongside sheetchange to autofilter if anything was added to the filters.
Sub Advanced_Filtering_ModV2()
Dim rc As Long, crc As Long, trc As Long
Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook: Set ws = wb.Worksheets("sheet1")
ws.Range("AA1").Value = ws.Range("Q1").Value: ws.Range("AA2").Value = ">"""""
On Error Resume Next
ws.ShowAllData: rc = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A1:V" & rc).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=ws.Range("AA1:AA2")
On Error GoTo 0
End Sub
I have been using a sheet where i have created a manual drop down through "Data Validation" and was using this below code to filter the Column.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastrow As Long
lastrow = Cells(Rows.Count, "I").End(xlUp).Row
With Me
If Not Intersect(Target, .Range("I13")) Is Nothing Then
If Target.Value <> "" Then
.AutoFilterMode = False
.Range("I15:I" & lastrow).AutoFilter field:=1, Criteria1:=Target.Value
End If
End If
End With
End Sub
But now I'm trying to do an ActiveX program that loads the Unique value in ComboBox1 from given range and Filter column using the Value of the ComboBox1.
Here is the code which gets the unique values.
Problem is that i have tried to merge both codes to make it work for ComboBox1 but couldn't make it.
Dim v, e
With Sheets("Sheet1").Range("I16:I10000")
v = .Value
End With
With CreateObject("scripting.dictionary")
.comparemode = 1
For Each e In v
If Not .exists(e) Then .Add e, Nothing
Next
If .Count Then Sheets("Sheet1").ComboBox1.List = Application.Transpose(.keys)
End With
I want to merge these both codes in one to work. I have tried but failed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastrow As Long
With Sheets("Sheet1").Range("I15:I" & lastrow)
v = .Value
End With
With CreateObject("scripting.dictionary")
.comparemode = 1
For Each e In v
If Not .exists(e) Then .Add e, Nothing
Next
If .Count Then Sheets("Sheet1").ComboBox1.List = Application.Transpose(.keys)
End With
lastrow = Cells(Rows.Count, "I").End(xlUp).Row
With Me
If Not Intersect(Target, .Range("I1")) Is Nothing Then
If Target.Value <> "" Then
.AutoFilterMode = False
.Range("I15:I" & lastrow).AutoFilter field:=1, Criteria1:=Target.Value
End If
End If
End With
You do not need the Worksheet_Change event anymore because you are not trapping the value from the data validation cell but from a ComboBox1. Paste this code (Untested) in the Sheet1 code area. The below code will automatically filter when you select an item from the ComboBox1. If you want you can also use a CommandButton to run this code.
Let me know if you face an issue?
Private Sub ComboBox1_Click()
If ComboBox1.ListIndex = -1 Then Exit Sub
Dim ws As Worksheet
Set ws = Sheet1
With ws
.AutoFilterMode = False
LastRow = .Range("I" & .Rows.Count).End(xlUp).Row
.Range("I15:I" & LastRow).AutoFilter Field:=1, Criteria1:=ComboBox1.Value
End With
End Sub
Also you need to load the ComboBox1. You can either do that using a CommandButton or you can use the Workbook_Open() event.
ManagerEmployeeSheet
A B
1 manager Employee
2 M1 E1
3 M1 E2
4 M1 E44
5 M1 E41
6 M1 E34
7 M2 E100
8 M2 E17
9 M2 E29 and so on
I am making a dynamic dashboard where I need the employees under each manager to be dynamically reflected.
DashboardSheet
A B
1 Input Manager M1 #basically user inputs one manager name here in this cell
2 E1
3 E2
4 E44
5 E41
6 E34
So when I input M1 manager in cell B1 of DashboardSheet , I should get all employees under him in below cells, similarly if I input any other manager , I should get all employees under that manager. Vlookup alone will return only the first employee corresponding to the manager, but i need all employees under him.
I have read that maybe vlookup with offset can do this. But I am not sure.
Can anyone please help?
If you have Office365 then you can easily do that with Filter formula. Try below formula as per screenshot.
=FILTER(B2:B9,A2:A9=E1)
If you do not have Office365 then use INDEX() and AGGREGATE() formula together. As per my screenshot use below formula to D2 cell.
=IFERROR(INDEX($B$2:$B$9,AGGREGATE(15,6,ROW($1:$9)/($A$2:$A$9=$E$1),ROW(1:1))),"")
What I started out on the assertion that what #Harun24HR can do with one formula VBA should be able to do with one line of code became the epic effort shown below. Obviously I failed. In the project's defense I point out that where you have formulas in a worksheet you should add protection to the sheet to prevent your formulas from being damaged and that adds significantly to the management effort, too.
With that said, the code below is a Worksheet_Change procedure which must be in the code module of your Dashboard sheet and responds to a change in cell B1 (TriggerRange). The function it calls can go with it to the same location. Adjust the 3 constants at the top of the code (a convenience #Harun can't offer because it's one of the advantages of using VBA). The point is that you can modify any or all of the 3 constants and never need to touch the rest of the code. That makes management whole a lot easier.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 083
Const TriggerRange As String = "B1" ' cell where the change occurs
Const MgrClm As String = "A" ' change to suit
Const EmpClm As String = "C" ' change to suit
Dim List As Variant ' list of employees under one manager
Dim OutputRng As Range ' range to write result to
With Target
If .Address(0, 0) = TriggerRange Then
Set OutputRng = Range(.Offset(1), Cells(.Rows.Count, .Column).End(xlDown))
' keep one blank between the last employee and any other column content
OutputRng.ClearContents
List = EmployeeList(.Value, Columns(MgrClm).Column, Columns(EmpClm).Column)
' write to the cell below the changed cell
Set OutputRng = .Offset(1).Resize(UBound(List))
OutputRng.Value = Application.Transpose(List)
End If
End With
End Sub
Private Function EmployeeList(ByVal Crit As String, _
ByVal MgrClm As Long, _
ByVal EmpClm As Long) As Variant
' 083
Dim Fun As Variant ' function return array
Dim FltMode As Boolean ' Filter set by user
Dim Rng As Range ' working range
Dim RngArea As Range ' areas of the filtered range
Dim n As Long ' index to Fun
Dim R As Long ' loop counter: Rows
With Worksheets("Employees")
If .AutoFilterMode Then
.Cells.AutoFilter
FltMode = True
End If
Set Rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, EmpClm).End(xlUp))
With Rng
ReDim Fun(1 To .Rows.Count)
.AutoFilter
.AutoFilter Field:=MgrClm, Criteria1:=Crit
End With
On Error Resume Next
Set Rng = .AutoFilter.Range.Offset(1, 0) _
.Resize(.AutoFilter.Range.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible) ' omit header row
If Err.Number = 0 Then
On Error GoTo 0
For Each RngArea In Rng.Areas
With RngArea
For R = 1 To .Rows.Count
n = n + 1
Fun(n) = .Cells(R, EmpClm).Value
Next R
End With
Next RngArea
End If
If Not FltMode Then .AutoFilter
End With
If n = 0 Then
n = 1
Fun(n) = "No subordinates"
End If
ReDim Preserve Fun(1 To n)
EmployeeList = Fun
End Function
Please, try the next VBA approach:
Copy the next Sub in a standard module. It will create a validation cell keeping the unique Manager names (not required, but helpful I think):
Sub setValidationUnique()
Dim shM As Worksheet, shD As Worksheet, rngV As Range, dict As Object
Dim lastRM As Long, i As Long
Set shM = Worksheets("ManagerEmployeeSheet")'use here your sheet name
Set shD = Worksheets("DashboardSheet") 'use here your sheet name
lastRM = shM.Range("A" & Rows.count).End(xlUp).row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRM
dict(shM.Range("A" & i).value) = 1
Next i
Set rngV = shD.Range("B1")
With rngV.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(dict.Keys, ",")
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
With shD.Range("A1")
.value = "Input Manager"
.Font.Bold = True
.EntireColumn.AutoFit
End With
shD.Activate: rngV.Select
End Sub
In the worksheet "DashboardSheet" module, copy the next event:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "B1" Then Exit Sub
Dim shM As Worksheet, arrE As Variant, k As Long
Dim lastRM As Long, i As Long
Set shM = Worksheets("ManagerEmployeeSheet")
lastRM = shM.Range("A" & Rows.count).End(xlUp).row
ReDim arrE(0 To lastRM)
For i = 2 To lastRM
If shM.Range("A" & i).value = Target.value Then
arrE(k) = shM.Range("B" & i).value: k = k + 1
End If
Next i
ReDim Preserve arrE(k - 1)
Target.Parent.Range(Target.Offset(1, -1), Target.Offset(1, -1).End(xlDown)).Clear
Application.EnableEvents = False
Target.Offset(1, -1).Resize(UBound(arrE) + 1, 1).value = WorksheetFunction.Transpose(arrE)
Application.EnableEvents = True
End Sub
Take care to appropriately name the necessary sheets, or name it "ManagerEmployeeSheet" and "DashboardSheet".
Play with the validated cell ("B1"), see the result and send some feedback.
I have a table with data from A5:S and would like to sort by a column with "segment" in headline every time a line is inserted.
I have made a numeric column to the left of my string column "segment" which matches my "ranking", the only issue is that it doesn't sort the rows automatically.
I have tried this VBA, but nothing happen:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:S" & lastRow).Sort key1:=Range("A5:A" & lastRow), order1:=xlAscending, Header:=xlGuess
End If
End Sub
If you keep a count of the #of rows in Column A, then when you insert a row, the worksheet_change event can run when the rows increase.
Possible adding enableevents to false would be a good idea so the change_evnt does not kick in when sorting
Dim LstRw As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rws As Long
Rws = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
If Rws > LstRw Then
Application.EnableEvents = False
MsgBox "Run your code here!"
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
LstRw = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
End Sub
What about if you change:
if target.column = 2 then
for
if activecell.column = 2 then
I have a table in Excel called tblFruits with 10 columns and I want to delete any rows where the Fruit column contains Apple. How can I do this?
The following sub works:
Private Sub deleteTableRowsBasedOnCriteria(tbl As ListObject, columnName As String, criteria As String)
Dim x As Long, lastrow As Long, lr As ListRow
lastrow = tbl.ListRows.Count
For x = lastrow To 1 Step -1
Set lr = tbl.ListRows(x)
If Intersect(lr.Range, tbl.ListColumns(columnName).Range).Value = criteria Then
'lr.Range.Select
lr.Delete
End If
Next x
End Sub
The sub can be executed like this:
Dim tbl As ListObject
Set tbl = ThisWorkbook.Worksheets("Sheet1").ListObjects("tblFruits")
Call deleteTableRowsBasedOnCriteria(tbl, "Fruit", "Apple")
Well, it seems the .listrows property is limited to either ONE list row or ALL list rows.
Easiest way I found to get around this was by:
Setting up a column with a formula that would point out to me all rows I would like to eliminate (you may not need the formula, in this case)
Sorting the listobject on that specific column (preferably making it so that my value to be deleted would be at the end of the sorting)
Retrieving the address of the range of listrows I will delete
Finally, deleting the range retrieved, moving cells up.
In this specific piece of code:
Sub Delete_LO_Rows
Const ctRemove as string = "Remove" 'value to be removed
Dim myLO as listobject, r as long
Dim N as integer 'number of the listcolumn with the formula
Set myLo = Sheet1.ListObjects("Table1") 'listobject goes here
With myLO
With .Sort
With .SortFields
.Clear
.Add Key:=.HeaderRowRange(myLO.ListColumns(N)), SortOn:= _
xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
On Error GoTo NoRemoveFound
r = Application.WorksheetFunction.Match(ctRemove, .ListColumns(.ListColumns.Count).DataBodyRange, 0)
Range(.parent.name & "!" & .DataBodyRange(r, 1).Address & ":" & .DataBodyRange(.ListRows.Count, .ListColumns.Count).Address).Delete xlShiftUp
'Added the .parent.name to make sure the address is on the correct sure, but it will fail if there are any spaces or characters on the sheet name that will make it need a pair of '.
'The error is just to skip these two lines in case the match returns an error. There's likely a better/cleaner way to do that.
NoRemoveFound:
End With
End sub
Hope it helps...