How to select Slicer Items with an array in VBA - arrays

I have a sheet with a number of pivot tables in Excel, which are controlled by one slicer to set a specific filter. I'm able to abstract the Slicer Items with a VBA function found on the internet:
Public Function GetSelectedSlicerItems(SlicerName As String) As String
Dim oSc As SlicerCache
Dim oSi As SlicerItem
Dim lCt As Long
On Error Resume Next
Application.Volatile
Set oSc = ThisWorkbook.SlicerCaches(SlicerName)
If Not oSc Is Nothing Then
For Each oSi In oSc.SlicerItems
If oSi.Selected Then
GetSelectedSlicerItems = GetSelectedSlicerItems & oSi.Name & ", "
lCt = lCt + 1
End If
Next
If Len(GetSelectedSlicerItems) > 0 Then
If lCt = oSc.SlicerItems.Count Then
GetSelectedSlicerItems = "All Items"
Else
GetSelectedSlicerItems = Left(GetSelectedSlicerItems, Len(GetSelectedSlicerItems) - 2)
End If
Else
GetSelectedSlicerItems = "No items selected"
End If
Else
GetSelectedSlicerItems = "No slicer with name '" & SlicerName & "' was found"
End If
End Function
Now, what I want to do, is to select the same Items in a different Slicer on another worksheet. So I've found another piece of code here on StackOverflow from #jeffreyweir, that works fine, as long as the array is hardcoded:
Sub Set_VfMSlicer()
Dim slr As Slicer
Dim sc As SlicerCache
Dim si As SlicerItem
Dim i As Long
Dim vItem As Variant
Dim vSelection As Variant
Set sc = ActiveWorkbook.SlicerCaches("Slicer_Afdeling")
'Set sc = slr.SlicerCache
vSelection = Array("DevOPs", "Functional Support", "Technical Support")
For Each pt In sc.PivotTables
pt.ManualUpdate = True 'Stops PivotTable from refreshing after each PivotItem is changed
Next pt
With sc
'At least one item must remain visible in the Slicer at all times, so make the first
'item visible, and at the end of the routine, check if it actually *should* be visible
.SlicerItems(1).Selected = True
'Hide any other items that aren't already hidden.
'Note that it is far quicker to check the status than to change it.
' So only hide each item if it isn't already hidden
For i = 2 To .SlicerItems.Count
If .SlicerItems(i).Selected Then .SlicerItems(i).Selected = False
Next i
'Make the PivotItems of interest visible
On Error Resume Next 'In case one of the items isn't found
For Each vItem In vSelection
.SlicerItems(vItem).Selected = True
Next vItem
On Error GoTo 0
'Hide the first PivotItem, unless it is one of the countries of interest
On Error Resume Next
If InStr(UCase(Join(vSelection, "|")), UCase(.SlicerItems(1).Name)) = 0 Then .SlicerItems(1).Selected = False
If Err.Number <> 0 Then
.ClearAllFilters
MsgBox Title:="No Items Found", Prompt:="None of the desired items was found in the Slicer, so I have cleared the filter"
End If
On Error GoTo 0
End With
For Each pt In sc.PivotTables
pt.ManualUpdate = False
Next pt
End Sub
I've tried to replace the vSelection = Array("DevOPs", "Functional Support", "Technical Support")
with: str = GetSelectedSlicerItems("Slicer_Afdeling1") vSelection = Split(str, ",")
which works, as long as only one item is selected in the source slicer. I want to be able to select multiple items as well. How can I fix this? The weird thing is that if a insert a msbBox in the loop to make the right items visible, it gives exactly the right items, which are also available in the slicer.
ps: the pivot tables are on different worksheets as well, but have the same range as source.

Related

Getting subscript out of range error for one variable specifically in an array

I am trying to set up a subroutine that protects and hides worksheets labeled as "restricted" and only protect worksheets labeled as "read only", as specified by the user in certain cells (see the image attached where the user would specify the status for each sheet). The code seems to work without a problem, only for the restricted portion of the sheets. However, as soon as I add the condition to check for the read only sheets, I get the subscript out of range error for the line marked by **, but the weird part is that its for the fourth element of the array always, so not sure why the first 3 work fine, or why adding the second condition stops it from working. If the "Case Read Only" and condition lines are taken out, it works fine. Maybe I am missing something obvious, I am fairly new to VBA as you can see by what is likely my inefficient code. Any help is very appreciated!
User table for selecting restricted and read only sheets
Private Sub Test()
Dim NumberOfSheets As Integer 'Variable for counting the sheets in model
NumberOfSheets = Application.Sheets.Count - 2 'Number of Sheets ignores Master Cmd sheet, and array starts at 0 so 2 is subtracted
Dim iCounter As Integer 'Counter for looping through the array
ReDim CheckWorksheets(NumberOfSheets) As String 'Restricted worksheet name variable declaration
Worksheets("Master Cmd").Activate 'Activate Master Cmd
Range("C7").Activate 'Activate first cell with sheet name
For iCounter = 0 To NumberOfSheets 'Loop to cycle through worksheet names
CheckWorksheets(iCounter) = ActiveCell.Offset(iCounter, 0) 'Setting array variable equal to worksheet name
Next iCounter
For iCounter = 0 To NumberOfSheets 'Loop to change restricted worksheets status to very hidden
Select Case ActiveCell.Offset(iCounter, 2)
Case "Restricted"
Worksheets(CheckWorksheets(iCounter)).Protect password:=AdminPassword 'Protecting sheets
Worksheets(CheckWorksheets(iCounter)).Visible = xlSheetVeryHidden 'Condition to see if status is restricted in Master Cmd sheet
Case "Read Only"
**Worksheets(CheckWorksheets(iCounter)).Protect password:=AdminPassword**
End Select
Next iCounter
End Sub
I would ditch the array. Untested:
Private Sub Test()
Const VAL_RESTRICTED = "Restricted"
Dim wb As Workbook, c As Range
Set wb = ThisWorkbook '? or ActiveWorkbook ?
For Each c In wb.Worksheets("Master Cmd").Range("C7").Resize(wb.Worksheets.Count - 1, 1).Cells
With wb.Worksheets(c.Value)
.Protect Password:=AdminPassword 'Protecting sheets
If c.Offset(0, 2).Value = VAL_RESTRICTED Then .Visible = xlSheetVeryHidden
End With
Next c
End Sub
Edit: to debug the original problem you could modify your code slightly.
Dim shtName
'...
'...
For iCounter = 0 To NumberOfSheets
shtName = CheckWorksheets(iCounter)
Debug.Print iCounter, shtName
Select Case ActiveCell.Offset(iCounter, 2)
Case "Restricted"
Worksheets(shtName).Protect password:=AdminPassword
Worksheets(shtName).Visible = xlSheetVeryHidden
Case "Read Only"
Worksheets(shtName).Protect password:=AdminPassword
End Select
Next iCounter
Note also it's good practice to explcitly qualify your Worksheets with a specific workbook. In this case it should be ThisWorkbook.Worksheets()

Display All Array Element Values in One MsgBox VBA

please bear with my code. (I'm not a good coder and not familiar with all VBA syntax.)
I'm creating a database for all our household books.
I'm not using ACCESS or SQL, just simply recording all UserForm input data to an Excel Sheet.
In my UserForm, all data, which has a category like: Author, Genre, Publisher, Location of the book in house, etc., are input through a ComboBox.
The initial RowSource of each ComboBox is a range in an excel sheet. In this range, I have already typed-in some items for each category. So, upon executing the Macros, when the dropdown arrow of each ComboBox is clicked, list items are shown.
The function of "Private Sub CmdEditList_Click()" in the code below is, first, to update the list of items in each category, if the data in each ComboBox is not found in the existing list. And second, to update the RowSource of each ComboBox.
The purpose of the MsgBox code line below, in which I have a problem, is to inform the user which of the Categories has an item added to it's list.`
MsgBox "The following Categories were updated:" & vbNewLine & msg`
But in cases for example that 3 categories (Author, Publisher & Series) are updated, Author and Publisher is not shown, instead after 2 newlines, only "Series" is shown.
What is the cause of the problem? What is the solution?
Private Sub CmdEditList_Click()
Dim NextListRow As Long
Dim ComboArr()
Dim RangeArr()
Dim MsgBoxArr()
Dim CategoryArr()
Dim i As Integer
Dim UpdateItemCnt As Integer
Dim mbi As Integer
Const LASTINDEX = 8
i = 0
UpdateItemCnt = -1
ComboArr = Array(ComboAuthor, ComboGenre, ComboPublisher, _
ComboLocation, ComboSeries, ComboPropertyOf, _
ComboRating, ComboRatedBy, ComboStatus)
RangeArr = Array("R", "S", "T", "U", "V", "W", "X", "Y", "Z")
CategoryArr = Array("Author", "Genre", "Publisher", "Location", "Series", _
"Property Of", "Rating", "Rated By", "Status")
Do While i <= LASTINDEX
'Checks each Combobox, if ther's a data input.
If Len(Trim(ComboArr(i).Value)) <> 0 Then
Set wkb = ThisWorkbook
wkb.Sheets("Database").Activate
With ActiveSheet
'Finds the cell, where a new item of a Category can be placed in the excel sheet.
NextListRow = .Cells(.Rows.Count, RangeArr(i)).End(xlUp).Row + 1
End With
'Check if the entered data is not in the existing list.
'If True, ComboBox data is in the list.
If Application.CountIf(Range(RangeArr(i) & "2" & ":" & RangeArr(i) & NextListRow), _
ComboArr(i).Value) > 0 Then
GoTo NextRoutine
Else
UpdateItemCnt = UpdateItemCnt + 1
ReDim MsgBoxArr(UpdateItemCnt)
MsgBoxArr(UpdateItemCnt) = CategoryArr(i)
MsgBox MsgBoxArr(0) 'To Check the value of MsgBoxArr(0) after 2nd assignment.
'Upon checking via debug simulation, the value = "".
'Assigns the ComboBox Value under its corresponding Category in excel sheet.
Database.Cells(NextListRow, RangeArr(i)).Value = ComboArr(i).Value
'Refreshes the range of the list to be displayed via the ComBox dropdown arrow.
Range(RangeArr(i) & "2", Range(RangeArr(i) & Rows.Count).End(xlUp)).Name = "Dynamic"
ComboArr(i).RowSource = "Dynamic"
End If
NextRoutine:
Else
GoTo EndRoutine
EndRoutine:
End If
i = i + 1
Loop
MsgBox MsgBoxArr(0) 'To Check the value of MsgBoxArr(0) after loop.
'Upon checking via debug simulation, the value = "".
For mbi = LBound(MsgBoxArr) To UBound(MsgBoxArr)
msg = msg & MsgBoxArr(mbi) & vbNewLine
Next mbi
MsgBox "The following Categories were updated:" & vbNewLine & msg
'In cases, wherein new item for Author, Publisher and Series were input in the UserForm,
'the MsgBox only shows: The following Categories were updated:
'
'
' Series
End Sub
ReDim MsgBoxArr(UpdateItemCnt)
should be
ReDim Preserve MsgBoxArr(UpdateItemCnt)
if you resize an array without Preserve then any existing content is lost

Update table cells based on criteria using an array

I have a dynamic master table on Worksheets("Jobs") that has fixed number of columns (A:M). Columns I and J are formulas.
On a different worksheet I have a textbox that will have a job # specified. I need values in columns L & M to change to "No" for the matching job #. My previous code was working too slow. I'm trying to rewrite the code using an array, but I have a hard time doing so.
The idea is to transfer the entire table to a memory-based array and make your changes to the array, then transfer the updated table data back to the worksheet.
Question is if I do that, wouldn't that clear the content that have formulas. Can I use two arrays from two header based named ranges for column B, then another for columns L:M? Working in that array, just update and transfer the values that just need to be changed.
Thank you for any help anyone can provide.
Here is my code so far:
Sub CloseJobarr()
Dim cell As Range
Dim Txt As String
Dim ws As Worksheet
Dim Arr1 As Variant, Arr2 As Variant
Arr1 = Range("JobCol_Master").Value '<--Column B of Master Data Table that is on ws
Arr2 = Range("OpenSCCols").Value '<--Columns L:M of Master Data Table that is on ws
Set ws = ThisWorkbook.Worksheets("Jobs")
With ThisWorkbook
Txt = .Worksheets("ID").TextBoxID.Text
If Txt <> "" Then
With ws
For Each cell In Arr1
'If job# matches textbox and if job# is to correct region then...
If cell.Text = Txt And .Cells(cell.row, 4).Value = "ID" Then
End If
Next cell
End With
End If
End With
MsgBox "Job not found."
End Sub
Updated Code below using Auto Filter (I'm still experiencing screen flicking). When a job # doesn't match I get a run time error message " no cells were found" and the debug line is: .Range("OpenSCCols").SpecialCells(xlCellTypeVisible).Value = "No"
Option Explicit
Sub CloseJobarraytesting()
ThisWorkbook.Sheets("Jobs").Unprotect Password:="Andersen"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo errHndl
Dim cell As Range
Dim Txt As String
Dim ws As Worksheet
With ThisWorkbook.Worksheets("Jobs") '<--| reference relevant worksheet
.Range("JobCol_Master").AutoFilter Field:=2, Criteria1:=Worksheets("ID").TextBoxID.Text '<--| filter its "JobCol_Master" named range on textbox ID
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell filtered other than header
.Range("OpenSCCols").SpecialCells(xlCellTypeVisible).Value = "No" '<-- write "OpenSCCols" named range filter cells, corresponding to the filtered ID
Else
MsgBox "Job not found."
End If
.AutoFilterMode = False
End With
CleanUp:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ThisWorkbook.Sheets("Jobs").Protect Password:="Andersen"
Exit Sub
errHndl:
MsgBox "Error happened while working on: " + vbCrLf + _
vbCrLf + vbCrLf + "Error " + _
Str(Err.Number) + ": " + Err.Description, vbCritical + vbOKOnly, "Error"
GoTo CleanUp
End Sub
edited to have the code check filtered cells on Range("JobCol_Master")
your aim is to actual filter data, then I believe that an AutoFilter() approach should be considerable fast
assuming you defined both JobCol_Master and OpenSCCols named ranges enclosing their corresponding headers cells, you can simply go like follows
Option Explicit
Sub CloseJobarr()
With ThisWorkbook.Worksheets("Jobs") '<--| reference relevant worksheet
With .Range("JobCol_Master")
.AutoFilter Field:=1, Criteria1:=Worksheets("ID").TextBoxID.Text '<--| filter its "JobCol_Master" named range on textbox ID
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell filtered other than header
.Parent.Range("OpenSCCols").SpecialCells(xlCellTypeVisible).Value = "No" '<-- write "OpenSCCols" named range filter cells, corresponding to the filtered ID
Else
MsgBox "Job not found."
End If
End With
.AutoFilterMode = False
End With
End Sub
should your named ranges not contain their headers the code can be easily adapted by means of some Offset() and Resize() method applied on them, but its much easier (and logic) to resize the named ranges and have them enclose their headers

VBA Live-filter listbox via textbox & save multiple selections from listbox in one cell

Hello again community,
After I got so much help from you with my last Problem, that promted me to rework the entire code in a more efficient manner, I would like to ask two more questions regarding the same Project.
(1) I would like to implement a live-filter in my listbox CGList1, which is connected to the textbox SearchCGList1. Whenever someone types in the textbox, the results in the listbox should be adjusted. I found this Article on your website, as well as this Article 3 on an external Webpage. However, due to my very limited skills, I have not been able to adapt it properly. More later.
(2) After multiple items from the same listbox CGList1 have been transferred to the second listbox CGList2 via a button (which works like a treat), I would like to save them in the same cell (Range "BM") on my Worksheet Meta DB. For this problem I also used Google extensively and tried to adapt the findings (see links below) for my code - without success.
I hope that the Patient ones amongst you can help me out once again, in the knowledge that I am trying to learn as much as possible. My Problem is that for a lot of things, I simply do not know what to look for.
My preliminary code for Problem 1:
CGList1 and CGList2 have no code. They are populated in the Userform_Initialize sub via:
'Fill Material Groups Listbox1 dynamically
Dim cell As Range
Dim rng As Range
With ThisWorkbook.Sheets("Commodity Groups")
'Range to 500 in order to allow for further additions
Set rng = .Range("A2", .Range("A500").End(xlUp))
End With
Me.CGList1.ColumnWidths = "20;80"
For Each cell In rng.Cells
'Filter out blanks
If cell <> "" Then
With Me.CGList1
.AddItem cell.value
.List(.ListCount - 1, 1) = cell.Offset(0, 1).value
End With
End If
Next cell
I cannot just use .AddItem and then filter through the columns like you find in many examples online because it needs to be dynamic and there are many blanks in between the selection items on the Worksheet.
The buttons:
Private Sub addCGbutton_Click()
For i = 0 To CGList1.ListCount - 1
If CGList1.Selected(i) = True Then
'Copy only CG Name, not respective number/letter combination (only more work to cut out when working with it later)
CGList2.AddItem CGList1.List(i, 1)
End If
Next i
End Sub
'Delete selected Commodity Groups from List 2 for re-selection
Private Sub delCGbutton_Click()
Dim counter As Integer
counter = 0
For i = 0 To CGList2.ListCount - 1
If CGList2.Selected(i - counter) Then
CGList2.RemoveItem (i - counter)
counter = counter + 1
End If
Next i
End Sub
After a lot of trial and failure trying to adapt the linked approaches from other people, I tried something more simple:
Private Sub SearchCGList1_Change()
'Only show with textbox matching items in CGList1 (filter)
Dim strSQL As String
strSQL = "SELECT fieldname FROM table WHERE fieldname = "
strSQL = strSQL & "'" & Me!SearchCGList1 & "*'"
strSQL = strSQL & " ORDER BY fieldname;"
Me!SearchCGList1.RowSource = strSQL
End Sub
But without success.
Regarding Problem 2:
To save the multiple selections from CGList2 in Range BM on Worksheet "Meta DB", I toyed around a lot and my last try was:
Save multiple selections from Commodity Group List 2 to the same cell in Excel
Dim listItems As String, c As Long
With CGList2
For c = 0 To .ListCount - 1
If .Selected(c) Then listItems = listItems & .List(c) & ", "
Next c
End With
Range("BM") = Left(listItems, Len(listItems) - 2)
Usually, all my other UserForm entries are saved with a single command button in the following fasion:
Private Sub CommandButton21_Click()
'Application.ScreenUpdating = False
'Define all relevant WBs we will be working with
Dim wbInput As Workbook
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets("Meta DB")
Dim LastRow As Long
'Save Userform Inputs
With ws
.Activate
LastRow = ws.Range("A" & Rows.Count).End(xlUp).row + 1
.
.
Range("BK" & LastRow).value = Me.payinfo90
Range("BL" & LastRow).value = Me.payinfo90more
'Risk Management - Residual Information
Range("BM" & LastRow).value = Me.CGList2
Range("BN" & LastRow).value = Me.suppsince
.
.
End With
End Sub
Again, I thank everyone who took the time to read my post and answer with tips on what to improve.
Everyone have a great day.
Using a helper column with array formula.
So if say you had your data for the 1st list box in a1:a10 and the selection from this listbox is placed in D1, the 2nd complete listbox selections are in B1:B10, but not used, then in E1:E10, I have the following array formula filled down, so you would populate the 2nd listbox off the helper column E.
Beginning with
=INDEX($B$1:$B$10,SMALL(IF(LEFT($B$1:$B$10,LEN($D$1))=$D$1,ROW($B$1:$B$10),""),ROWS($E$1:$E1)),1)
Containing
=INDEX($B$1:$B$10,SMALL(IF(NOT(ISERR(SEARCH($D$1,$B$1:$B$10))),ROW($B$1:$B$10)),ROWS($E$1:E1)),1)
You need to press CTRL SHIFT and ENTER for array formula.

Copy values in a column from multiple worksheets into one

The problem is the following: I have an excel file with multiple worksheets and I needed to copy the G column from every worksheet to a single new worksheet ( the columns should be next to each other or with an empty column between the columns with data). I also wanted to ask if it is possible to put the name of each worksheet above the corresponding column.
Until now, I used this code:
Sub Copy_G_Columns()
Dim ws As Worksheet, i As Long
Application.ScreenUpdating = False
On Error Resume Next
Set ws = Sheets("Gee Columns")
If Err.Number <> 0 Then
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count): ActiveSheet.Name = "Gee Columns"
On Error GoTo 0
Else
Sheets("Gee Columns").Select
End If
For i = 1 To ActiveWorkbook.Sheets.Count - 1
With Sheets(i)
.Range("G1:G" & .Cells(.Rows.Count, 7).End(xlUp).Row).Copy Cells(2, i * 2 - 1)
Cells(1, i * 2 - 1) = Sheets(i).Name
End With
Next i
Application.ScreenUpdating = True
End Sub
It seems to almost work perfectly. The only problem is that in the new created sheet, the values in the columns have a #DIV/0 error. I think the problem is that the code is copying the formats and not the values.
Here is my interpretation of your code.
Option Explicit
Sub allGEE()
Dim w As Long, wsn As String, vGEEs As Variant
wsn = "Gee Columns"
For w = 1 To Worksheets.Count
With Worksheets(w)
On Error GoTo bm_NeedWorksheet
If .Name <> Worksheets(wsn).Name Then
On Error GoTo bm_Safe_Exit
vGEEs = .Range(.Cells(1, 7), .Cells(Rows.Count, 7).End(xlUp)).Value
vGEEs(1, 1) = .Name
With Worksheets(wsn).Cells(1, w * 2 - 1)
.Resize(UBound(vGEEs, 1), UBound(vGEEs, 2)) = vGEEs
End With
End If
End With
Next w
GoTo bm_Safe_Exit
bm_NeedWorksheet:
On Error GoTo 0
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = wsn
End With
Resume
bm_Safe_Exit:
End Sub
I've retained the stagger in the destination cells. I strongly suspect that you were copying formulas across and needed the values only. Transferring values with a variant array (without the clipboard) is quicker. Direct value transfer is also possible but you wanted to put the origin worksheet name into the first cell(s).

Resources