Display All Array Element Values in One MsgBox VBA - arrays

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

Related

How to select Slicer Items with an array in VBA

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.

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.

Using an array to specify worksheets to print

I have a workbook from which I want to select certain worksheets to export.
This will vary each time and the names of the worksheets appear in cells Y48:Y55 based on whether they are selected above:
selected cells and populated list
I would like to use this list to fill a dynamic array which I can call to export to pdf only the sheets in the array.
I have got the array in vba that I can see in a message box, I just can't get it into the Sheets(Array(myarray).select part of the code.
If I type all the values in manually eg. sheets(Array("COVER", "CLASS CHART").Select it will work, but I don't know how to get the individual values out of myarray.
Sorry I'm not a coder but I can't find this anywhere.
So far it looks like this:
Dim myarray() As String, size As Integer, i As Integer
size = WorksheetFunction.CountA(Range("y48:y55"))
ReDim myarray(size)
For i = 1 To size
myarray(i) = Cells(i + 47, 25).Value
Next i
MsgBox (size)
MsgBox Join(myarray, vbCrLf)
Sheets(myarray().Select
Sheets("COVER").Activate
answer = MsgBox("Do you want to export to PDF?", vbYesNo + vbQuestion, "Export to PDF")
If answer = vbYes Then
fileSaveName = Application.GetSaveAsFilename("", fileFilter:="PDF (*.pdf), *.pdf")
If fileSaveName <> False Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fileSaveName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End If
End If
Sheets("REPORT").Select
End Sub
Instead of using Sheets(myarray().Select, use a loop:
For i = Lbound(myarray,1) to Ubound(myarray,1)
Worksheets(myarray(i)).Select False
Next i
The false makes it so it doesn't lose it's previous selection.

Storing Listbox Value Generated by a Row Source Query

I am trying to store the value of a listbox (Actual_Polygon_Area) that has been generated via row source query. Each time I run the script my message box tells me that the value of the listbox is null and I suspect it's caused by the row source. The suspected listbox is named Actual_Polygon_Area and the field I am trying to store it in is Polygon_Area within the table FS_Actual_Polygon.
Private Sub Actual_Polygon_Save_Click()
If IsNull(Actual_Polygon_Year) Then
MsgBox "Please enter a year in which this polygon received treatment"
Actual_Polygon_Year.SetFocus
ElseIf IsNull(Actual_Polygon_Season) Then
MsgBox "Please enter the season in which this polygon received treatment"
Actual_Polygon_Season.SetFocus
ElseIf IsNull(Actual_Polygon_Treatment) Then
MsgBox "Please select the treatment type that was completed in this polygon."
Actual_Polygon_Treatment.SetFocus
ElseIf IsNull(Actual_Polygon_Notes) Then
MsgBox "Please write a short summary regarding treatment goals and objectives."
Actual_Polygon_Notes.SetFocus
ElseIf IsNull(Actual_Polygon_Area) Then
MsgBox "Polygon Area is null, please enter a value"
Actual_Polygon_Area.SetFocus
Else
Dim MyConnection As ADODB.Connection
Set MyConnection = CurrentProject.Connection
Dim rsFS_Actual_Polygon As ADODB.Recordset
Set rsFS_Actual_Polygon = New ADODB.Recordset
If IsNull(PolygonNo) Then
'add
rsFS_Actual_Polygon.Open "select * from FS_Actual_Polygon where PolygonNo= " & Actual_Polygon_ID & " and Treatment_Season= '" & Actual_Polygon_Season & "' and Treatment_Type= '" & Actual_Polygon_Treatment & "' and Project_Name = '" & Actual_Polygon_Project_Name & "' and Polygon_Area = " & Actual_Polygon_Area.Value & " and Treatment_Year = " & Actual_Polygon_Year, _
MyConnection, adOpenDynamic, adLockOptimistic
If Not rsFS_Actual_Polygon.EOF Then
MsgBox "The combination of Polygon ID, treatment-year, treatment-season, and treatment type already exist. Please check the combination."
Actual_Polygon_Year.SetFocus
Else
With rsFS_Actual_Polygon
.AddNew
![PolygonID] = Actual_Polygon_ID
![Project_Name] = Actual_Polygon_Project_Name
![Polygon_Area] = Actual_Polygon_Area.Value
![Treatment_Year] = Actual_Polygon_Year
![Treatment_Season] = Actual_Polygon_Season
![Treatment_Type] = Actual_Polygon_Treatment
![Polygon_Notes] = Actual_Polygon_Notes
.Update
End With
Actual_Polygon_Record.Requery
Actual_Polygon_New_Click
End If
I can post the rest of the code if necessary, I just didn't want to post a huge chunk.
You can use the .ItemsSelected and .ItemData methods to find and pass the value of the selected row from the listbox to your table.
This is a fairly typical use of the listbox control, and is a little easier than dealing with a multi-select control, but is still a bit cumbersome. You will need to create a For Each...Next loop to collect the row number of the selected row in your listbox and save to a variable. Then use that variable as the argument of the .ItemData method to return the bound column value for that selected row.
This MSDN article should have everything you need.
EDIT: While the above solution works for multi and single select listboxes, there is a more expedient way for single select listboxes:
Dim i as Integer
i = Me!Actual_Polygon_Area.ListIndex
If i = -1 Then
MsgBox "No item has been selected"
Exit Sub
End If
'Do above prior to `WITH` loop
...'Then in your `WITH` loop:
![Polygon_Area] = Actual_Polygon_Area.ItemData(i)

Resources