I found this Code on the internet, it should make those little arrows from the dropdownmenu visible. This works, but I would like to make only the following cells visible:
B2,B11,B12,B13
Sub ShowArrowsExceptOne()
'shows all arrows except
' in specified field number
Dim c As Range
Dim rng As Range
Dim i As Long
Dim iHide As Long
Set rng = ActiveSheet.AutoFilter.Range.Rows(1)
i = 1
iHide = 3 'leave this field's arrow hidden
Application.ScreenUpdating = False
For Each c In rng.Cells
If i = iHide Then
c.AutoFilter Field:=i, _
Visibledropdown:=False
Else
c.AutoFilter Field:=i, _
Visibledropdown:=True
End If
i = i + 1
Next
Application.ScreenUpdating = True
End Sub
I tried it the following way:
Dim i As Long
Dim iHide As Long
i = 1
iHide = 3 'leave this field's arrow hidden
Application.ScreenUpdating = False
With Intro.Range("B2")
.AutoFilter Field:=2, _
Visibledropdown:=True
End With
Application.ScreenUpdating = True
But it always makes the dropdowns visible on B1,C1 and D1
Can anybody help me on this?
Related
If a name appears in Listbox2, i need to search a sheet with any matching names and update column 9 from 0 to 1. Currently, the code i have nearly works, but does not account for names that appear more than 1 time in the sheet. So only the first time a name appears in the sheet, does column 9 update from 0 to 1.
Below is the code im using:
Private Sub CommandButton6_Click()
ThisWorkbook.RefreshAll
Dim i As Integer
Dim wks As Worksheet
Set wks = Sheet1
For i = 0 To ListBox2.ListCount - 1
ListBox2.Selected(i) = True
rw = wks.Cells.Find(What:=Me.ListBox2.List(i), SearchOrder:=xlRows,
SearchDirection:=xlNext, LookIn:=xlValues, lookat:=xlWhole).Row
wks.Cells(rw, 9).Value = "1"
Next i
Sheet3.Shapes("Button 3").Visible = Sheet1.Cells(1, 26) > "0"
MsgBox ("Update Successful")
Me.Hide
ListBox2.Clear
ThisWorkbook.RefreshAll
End Sub
Thank you for any help
You can use Find in this way to look for something which occurs more than once. You store the address of the first found cell, and then loop until you return to this cell which tells you that you've found all instances. When using Find it's also worth checking first that your value is found - your code would error if the term were not found.
Private Sub CommandButton6_Click()
ThisWorkbook.RefreshAll
Dim i As Long
Dim wks As Worksheet, r As Range, s As String
Set wks = Sheet1
For i = 0 To ListBox2.ListCount - 1
ListBox2.Selected(i) = True
Set r = wks.Cells.Find(What:=Me.ListBox2.List(i), SearchOrder:=xlRows, _
SearchDirection:=xlNext, LookIn:=xlValues, lookat:=xlWhole)
If Not r Is Nothing Then
s = r.Address
Do
wks.Cells(r.Row, 9).Value = 1
Set r = wks.Cells.FindNext(r)
Loop Until r.Address = s
End If
Next i
Sheet3.Shapes("Button 3").Visible = Sheet1.Cells(1, 26) > "0"
MsgBox ("Update Successful")
Me.Hide
ListBox2.Clear
ThisWorkbook.RefreshAll
End Sub
I have a large table and the information I'm wanting to add comments to falls within Range(D11:CY148). I have two tabs - "Finish Matrix" (main) and "list" (hidden - has 2 columns).
I have two issues.
First issue - Code works to a degree, after I type my values within a cell it automatically adds comments based off info in another sheet. The problem is there is too many cells to be manually typing into and if I copy and paste the code doesn't run. I created a CommandButton and wanted it to refresh the entire table with comments depending if the cells had the values that fall within "list". I tried to create a call out to Worksheet_Change but to no avail. (I'm a beginner so it'll help if you explain)
Second issue - I'm assuming it'll get fixed with whatever suggestion that works. Occasionally after typing into a cell I would get an error. Can't remember the error name but it is one of the common ones, atm the error isn't popping up but surely it'll come back since I didn't do anything different to the code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("A:CX")) Is Nothing Then _
If Intersect(Target, Columns("CY")) Is Nothing Then Exit Sub
Dim lRow As Integer
lRow = Sheets("list").Range("A1").End(xlDown).Row
If Target.Value = vbNullString Then Target.ClearComments
For Each cell In Sheets("list").Range("A1:A" & lRow)
If cell.Value = Target.Value Then
Target.AddComment
Target.Comment.Text Text:=cell.Offset(0, 1).Value
End If
Next cell
End Sub
Thanks for any and all help!
You are basically missing the For Each Cell in Target part...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsMain As Worksheet, wsList As Worksheet
Dim cell As Range
Dim vCommentList As Variant
Dim i As Long, lLastRow As Long
Dim sValue As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wsMain = Target.Parent
Set Target = Intersect(Target, wsMain.Range("D11:CY148"))
If Target Is Nothing Then Exit Sub
Set wsList = wsMain.Parent.Sheets("list")
lLastRow = LastRow(1, wsList)
' Read Comment List into Variant (for speed)
vCommentList = wsList.Range("A1:B" & lLastRow)
Target.ClearComments
' This...For each Cell in Target...is what you were missing.
For Each cell In Target
sValue = cell
For i = 1 To UBound(vCommentList)
If sValue = vCommentList(i, 1) Then
AddComment cell, CStr(vCommentList(i, 2))
Exit For
End If
Next
Next
ErrHandler:
If Err.Number <> 0 Then Debug.Print Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Proper way to find last row ...
Public Function LastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
LastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function
Add Comment Sub the allows appending is needed...
Public Sub AddComment(Target As Range, Text As String)
If Target.Count = 1 Then
If Target.Comment Is Nothing Then
Target.AddComment Text
Else
Target.Comment.Text Target.Comment.Text & vbLf & Text
End If
End If
End Sub
Untested, but this will take all the values in Range(D11:CY148) and add a comment based on a lookup from Sheet "list".
Sub testy()
Dim arr As Variant, element As Variant
Dim i As Long, j As Long, listItems As Long, rwLast As Long, clLast As Long
Dim comm As String
Dim rng As Range, cell As Range
listItems = Sheets("list").Range("A1").End(xlDown).Row
rwLast = Cells.SpecialCells(xlCellTypeLastCell).Row ' Adjust to fit your needs
clLast = Cells.SpecialCells(xlCellTypeLastCell).Column 'Idem
Set rng = Sheets("list").Range("A1:A" & listItems)
arr = Range("D11:CY148").Value
With Worksheets("Finish Matrix")
For i = 1 To rwLast - 10 'Adjust to make it more general, this is pretty rough
For j = 1 To clLast - 3 'Idem
If i = 3 Then
End If
comm = ""
For Each cell In rng
If arr(i, j) = cell.Value Then
comm = comm & Chr(13) & cell.Offset(0, 1).Value
End If
Next cell
If Not (comm = "") Then
.Cells(10, 3).Offset(i, j).ClearComments
.Cells(10, 3).Offset(i, j).AddComment
.Cells(10, 3).Offset(i, j).Comment.Text Text:=comm
End If
Next j
Next i
End With
End Sub
Is there a way to speed this code up? I need it to remove and write the same content to the cell to force other VBA code to run that's on another column. Which is what it does, just super damn slow. And there is sometimes 2000 entries/rows on this sheet. Its about 3 seconds per cell, and it almost maxes my CPU out lol. (i7 6850k # 4.4ghz).
Reason for it, is sometimes the data is copied from an old version of the spreadsheet to a new version, and the VBA updated columns wont update, unless I physically change the cell its checking.
Sub ForceUpdate()
On Error GoTo Cleanup
Application.ScreenUpdating = False ' etc..
ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
r = r + 1
End If
Next cell
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", _
AllowSorting:=True, AllowFiltering:=True
End Sub
The code in the other VBA section is
If StrComp("pp voice", Target.Value, vbTextCompare) = 0 Then
Target.Value = "PP Voice"
Target.Offset(0, 8).Value = "N\A"
Target.Offset(0, 8).Locked = True
Target.Offset(0, 10).Value = "N\A"
Target.Offset(0, 10).Locked = True
End If
Target.Value is referring to the E column in the first piece of code. At the moment I have the first piece attached to a button, but it's way to slow. And the target machines are no where near as powerful as mine.
Use application.enableevents = false and application.calculation = xlcalculationmanual. Turn them back on before exiting. You must be either triggering an large event or complex calculation cycle if it it taking 3 seconds per cell.
Change,
Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
r = r + 1
End If
Next cell
... to,
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim cell As Range
With ThisWorkbook.Sheets("Sales Entry")
For Each cell In .Range("E2:E10")
If CBool(Len(cell.Value2)) Then
cell = cell.Value2
End If
Next cell
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Try this
Option Explicit
Sub ForceUpdate()
On Error GoTo Cleanup
Dim SalesEntrySheet As Worksheet
Set SalesEntrySheet = ThisWorkbook.Sheets("Sales Entry")
Application.ScreenUpdating = False ' etc..
SalesEntrySheet.Unprotect "password!"
Dim cell As Range, r As Long
Dim ArrayPos As Long
Dim SalesEntrySheetArray As Variant
With SalesEntrySheet
'Starting with row one into the array to ease up the referencing _
so Array entry 2 will be for row 2
SalesEntrySheetArray = .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)
'Clearing the used range in Col E
'If you are using a WorkSheet_Change for the second part of your code then you should rather make this a loop
.Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value = ""
'Putting the values back into the sheet
For ArrayPos = 2 To UBound(SalesEntrySheetArray, 1)
.Cells(ArrayPos, "E").Value = SalesEntrySheetArray(ArrayPos, 1)
Next ArrayPos
End With
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, _
AllowFiltering:=True
End Sub
Try to use with statement.
and take a look at Optimizing VBA macro
Sub ForceUpdate()
On Error GoTo Cleanup
Application.ScreenUpdating = False ' etc..
ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
Dim cell As Range, r As Long
r = 2
With ThisWorkbook.Sheets("Sales Entry")
For Each cell In .Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
.Cells(4, r) = ""
.Cells(4, r) = old
r = r + 1
End If
Next cell
End With
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, AllowFiltering:=True
End Sub
I'm trying to create an advanced filter for the below table but the code below is just hiding the cells. It's working but my problem with it is if i filter something and then I drag to fill status or any other cells it will override the cells in between for example in filter mode I have 2 rows one is 1st row and the other one is at row 20 if I drag to fill status it will replace the status of all cells in between 1 and 20 and don't know how to work it out, i know this happens because I'm hiding the cells and not actually filtering them.
Any help will be much appreciated.
[Data Table][1]
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
r1 = Target.Row
c1 = Target.Column
If r1 <> 3 Then GoTo ending:
If ActiveSheet.Cells(1, c1) = "" Then GoTo ending:
Dim LC As Long
With ActiveSheet
LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
End With
ActiveSheet.Range("4:10000").Select
Selection.EntireRow.Hidden = False
LR = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For r = 5 To LR
For c = 1 To LC
If ActiveSheet.Cells(2, c) = "" Or ActiveSheet.Cells(3, c) = "" Then GoTo nextc:
If ActiveSheet.Cells(2, c) = "exact" And UCase(ActiveSheet.Cells(r, c)) <> UCase(ActiveSheet.Cells(3, c)) Then ActiveSheet.Rows(r).EntireRow.Hidden = True: GoTo nextr:
If Cells(2, c) = "exact" Then GoTo nextc:
j = InStr(1, UCase(ActiveSheet.Cells(r, c)), UCase(ActiveSheet.Cells(3, c)))
If ActiveSheet.Cells(2, c) = "partial" And j = 0 Then ActiveSheet.Rows(r).EntireRow.Hidden = True: GoTo nextr:
nextc:
Next c
nextr:
Next r
ending:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The below code will be the answer to the question on how to create an advanced search based on multiple criteria on what the user selects in the table.
I will need a little bit of help with how to check if the user selected by mistake an empty cell I will need to make excel ignore filtering the blank cell. Also, I will need to make excel first to check if the yellow cells A3 to T3 has data in and if it has and i press the filter button will filter by the range A3:T3 and ignore the current user selection if there is no data in range A3:T3 will filter by the user selection and in the range A3:T3, if it has data will only filter by data cell that has data in them and ignore empty ones.
Sub advancedMultipleCriteriaFilter()
Dim cellRng As Range, tableObject As Range, subSelection As Range
Dim filterCriteria() As String, filterFields() As Integer
Dim i As Integer
If Selection.Rows.Count > 1 Then
MsgBox "Cannot apply filters to multiple rows within the same column. Please make another selection and try again.", vbInformation, "Selection Error!"
Exit Sub
End If
Application.ScreenUpdating = False
i = 1
ReDim filterCriteria(1 To Selection.Cells.Count) As String
ReDim filterFields(1 To Selection.Cells.Count) As Integer
Set tableObject = Selection.CurrentRegion
For Each subSelection In Selection.Areas
For Each cellRng In subSelection
filterCriteria(i) = cellRng.Text
filterFields(i) = cellRng.Column - tableObject.Cells(1, 1).Column + 1
i = i + 1
Next cellRng
Next subSelection
With tableObject
For i = 1 To UBound(filterCriteria)
.AutoFilter field:=filterFields(i), Criteria1:=filterCriteria(i)
Next i
End With
Set tableObject = Nothing
Application.ScreenUpdating = True
End Sub
Sub resetFilters()
Dim sht As Worksheet
Dim LastRow As Range
Application.ScreenUpdating = False
On Error Resume Next
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Range("A3:T3").ClearContents
Application.ScreenUpdating = True
Call GetLastRow
End Sub
Private Sub GetLastRow()
'Step 1: Declare Your Variables.
Dim LastRow As Long
'Step 2: Capture the last used row number.
LastRow = Cells(Rows.Count, 8).End(xlUp).Row
'Step 3: Select the next row down
Cells(LastRow, 8).Offset(1, 0).Select
End Sub
The code takes an active cell and if it is in the appropriate column, and has the value "YES" it runs one of two codes (depending on whether it is a summary or an individual value). This done on 'raw' data that is not in a table or pivot table.
About half the time that I double click on any cell in that sheet it jumps my active cell to either the top or bottom of the range of cells. What is causing this? What can I do to fix it?
This happens on both "YES" and "NO" cells.
Edit: Figured it out. It's an excel shortcut I was not aware of (I don't use the mouse much on excel). Double clicking a cells border jumps you to the top or bottom of that section. Is there a way in VBA to disable this 'feature' for a specific sheet. I can't seem to find any info on Google about it...
Edit 2: Found this: https://superuser.com/questions/610805/disable-navigate-to-end-of-list-when-double-clicking-on-border-of-selected-cell
But I do not want to disable drag and drop in the worksheet AND I want to do it with VBA.
Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Value <> "YES" Then
Exit Sub
Else
If Target.Column <> 11 Then
Exit Sub
Else
Cancel = False
Dim j As String
Dim k As String
Dim i As Range
Application.ScreenUpdating = False
Set i = Target
k = i.Offset(0, -7).Value 'First value for filter
Worksheets("Comments").Activate
If Worksheets("Comments").AutoFilterMode = True Then
Worksheets("Comments").AutoFilterMode = False
End If
If i.Offset(-1, 0).Value = "Comments" Then
j = i.Offset(-1, -9).Value
Worksheets("Comments").Range("C2").AutoFilter Field:=3, Criteria1:=j
Else
j = i.Offset(0, -9).Value
Worksheets("Comments").Range("C2").AutoFilter Field:=4, Criteria1:=k
Worksheets("Comments").Range("C2").AutoFilter Field:=3, Criteria1:=j
End If
Application.ScreenUpdating = True
Worksheets("Comments").Range("A1").Activate
End If
End If
Cancel = True
End Sub
First of all, let me organize your code, it is not very easy to read. Hope this works, I cannot try it right now.
Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim j As String
Dim k As String
Dim i As Range
Application.ScreenUpdating = False
Cancel = False
Set i = Target
If Target.Value <> "YES" and Target.Column <> 11 Then
Application.ScreenUpdating = True
Exit Sub
Else
Application.CellDragAndDrop = False
k = i.Offset(0, -7).Value 'First value for filter
Worksheets("Comments").Activate
If Worksheets("Comments").AutoFilterMode = True Then
Worksheets("Comments").AutoFilterMode = False
End If
If i.Offset(-1, 0).Value = "Comments" Then
j = i.Offset(-1, -9).Value
Worksheets("Comments").Range("C:C").AutoFilter Field:=3, Criteria1:=j
Else
j = i.Offset(0, -9).Value
Worksheets("Comments").Range("C:C").AutoFilter Field:=4, Criteria1:=k
Worksheets("Comments").Range("C:C").AutoFilter Field:=3, Criteria1:=j
End If
Application.ScreenUpdating = True
Worksheets("Comments").Range("A1").select
End If
Application.CellDragAndDrop = true
Cancel = True
End Sub