Subscript out of range error in Excel VBA when I add a new worksheet at the end of the list of worksheets only when the VB window is closed - excel

I have built an Excel Workbook that is intended for evaluation of an organization as a whole and then evaluation of each of several sites for that organization. There is an initial assessment and then an on-site assessment for the organization, and for each facility. Depending on the organization, the number of facilities will vary. There is a first "Configuration" tab where the user of the workbook enters (or copies and pastes) the list of facilities and determines which facilities are to be included in the evaluation.
The second and third worksheets are the assessment for the organization as a whole, and the fourth and fifth worksheets are template assessment forms for the facilities.
Once the list of facilities is entered, the user clicks on a button labeled "Create Facility Tabs" that steps through the facility list and creates the needed worksheets for each facility.
If the list is fresh (starting from its initial form), then the template worksheets are renamed for the first facility and new worksheets are created for the remainder.
If there are already worksheets identified, the software checks each facility to see if its page already exists, and only creates additional worksheets for newly added facilities.
When additional worksheets are needed, the code first counts the number of additional worksheets that are needed (two for each facility), creates those worksheets, and then steps through them copying the template contents onto the forms and the change code for the worksheets into the worksheet's module.
The software works perfectly over and over again when I have the VBA window open. It does everything it is supposed to do. However, when I close the VBA window, the code creates all the worksheets, copies everything into the first worksheet, and then raises a Subscript Out of Range error. Any ideas what I am doing wrong?
Here is the code:
Public Sub CreateFacilities()
Dim row As Long
Dim facility_name As String
Dim facility_list As String
Dim facilities As Variant
Dim include As Boolean
Dim ws_init As Worksheet
Dim ws_fac As Worksheet
Dim ws_new_init As Worksheet
Dim ws_new_fac As Worksheet
Dim ws_config As Worksheet
Dim facility_count As Long
Dim tabs_to_create As Long
Dim fac_initial_range As Range
Dim fac_initial_address As String
Dim fac_onsite_range As Range
Dim fac_onsite_address As String
Dim message As String
Dim title As String
Dim answer As Variant
Dim code_line As String
Dim b_width As Long
Dim c_width As Long
Dim counter As Long
Dim init_sheet_number As Long
Dim fac_sheet_number As Long
Dim tab_count As Long
title = "Creating Facility Tabs"
message = "Before you execute this function you should" & vbCrLf & "add any study-specific questions to the" & vbCrLf
message = message & "Initial Assessment - Facility1 and" & vbCrLf & "On-Site Assessment - Facility1 tabs so" & vbCrLf
message = message & "they will be included on the created facility tabs" & vbCrLf & vbCrLf
message = message & "Do you wish to continue?"
answer = MsgBox(message, vbYesNo + vbQuestion, title)
If answer = vbNo Then
Exit Sub
End If
Set ws_config = ThisWorkbook.Sheets("Configuration")
Set ws_init = ThisWorkbook.Sheets(4)
Set ws_fac = ThisWorkbook.Sheets(5)
b_width = ws_init.Columns("B").ColumnWidth
c_width = ws_init.Columns("C").ColumnWidth
Set fac_initial_range = ws_init.Range("A1:C" & Trim(Str(FindLastRow(ws_init))))
Set fac_onsite_range = ws_fac.Range("A1:C" & Trim(Str(FindLastRow(ws_fac))))
fac_initial_address = fac_initial_range.address
fac_onsite_address = fac_onsite_range.address
code_line = ThisWorkbook.VBProject.VBComponents("Module1").CodeModule.Lines(1, 50) 'get code for each new worksheet
facility_list = "" 'get list of facilities
facility_count = 0
For row = 4 To 54
facility_name = ThisWorkbook.Sheets("Configuration").cells(row, 2).value
include = ThisWorkbook.Sheets("Configuration").cells(row, 4).value
If facility_name = "" Then 'reached the end of the list
Exit For
Else:
If include Then 'the Do Assessment column is marked TRUE
If Not WorksheetExists(facility_name) Then 'the tabs for this facility do not already exist
facility_list = facility_list & facility_name & ","
End If
End If
End If
Next row
facility_list = Left(facility_list, Len(facility_list) - 1) 'remove trailing comma
If facility_list = "" Then 'no new facilities were added to the list
MsgBox "There were no facilties specified for inclusion"
Exit Sub
End If
facilities = Split(facility_list, ",") 'there is a list of facilities to add
facility_count = UBound(facilities) + 1
If ActiveWorkbook.Sheets.Count = 5 Then 'no facility tabs have been added
If facility_count = 1 Then 'there is only one facility - no tabs need to be added
tabs_to_create = 0
facility_name = facilities(0)
ws_init.Name = CreateInitialTabName(facility_name)
ws_fac.Name = CreateOnSiteTabName(facility_name)
Else:
tabs_to_create = (facility_count - 1) * 2
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count), Count:=tabs_to_create
For counter = LBound(facilities) To UBound(facilities)
facility_name = facilities(counter)
If counter = 0 Then 'rename the first two facility worksheets that already exist
ws_init.Name = CreateInitialTabName(facility_name)
ws_fac.Name = CreateOnSiteTabName(facility_name)
Else: 'for the rest, add worksheets and copy template content and code
init_sheet_number = ((counter - 1) * 2) + 6
fac_sheet_number = init_sheet_number + 1
Set ws_new_init = ActiveWorkbook.Sheets(init_sheet_number) 'create initial assessment sheet for facility
ws_new_init.Columns("B").ColumnWidth = b_width
ws_new_init.Columns("C").ColumnWidth = c_width
ws_new_init.Name = CreateInitialTabName(facility_name)
fac_initial_range.Copy Destination:=ws_new_init.Range("A1")
ThisWorkbook.VBProject.VBComponents(ws_new_init.CodeName).CodeModule.AddFromString code_line
Set ws_new_fac = ActiveWorkbook.Sheets(fac_sheet_number) 'create on-site assessment sheet for facility
ws_new_fac.Columns("B").ColumnWidth = b_width
ws_new_fac.Columns("C").ColumnWidth = c_width
ws_new_fac.Name = CreateOnSiteTabName(facility_name)
fac_onsite_range.Copy Destination:=ws_new_fac.Range("A1")
ThisWorkbook.VBProject.VBComponents(ws_new_fac.CodeName).CodeModule.AddFromString code_line
End If
Next counter
End If
Else: 'there are more than 5 tabs in the workbook - some were already added
tab_count = ActiveWorkbook.Sheets.Count
tabs_to_create = facility_count * 2
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(tab_count), Count:=tabs_to_create
For counter = LBound(facilities) To UBound(facilities)
facility_name = facilities(counter)
init_sheet_number = (counter * 2) + (tab_count + 1)
fac_sheet_number = init_sheet_number + 1
Set ws_new_init = ActiveWorkbook.Sheets(init_sheet_number)
Set ws_new_fac = ActiveWorkbook.Sheets(fac_sheet_number)
ws_new_init.Name = CreateInitialTabName(facility_name)
ws_new_fac.Name = CreateOnSiteTabName(facility_name)
ws_new_init.Columns("B").ColumnWidth = b_width
ws_new_fac.Columns("B").ColumnWidth = b_width
ws_new_init.Columns("C").ColumnWidth = c_width
ws_new_fac.Columns("C").ColumnWidth = c_width
fac_initial_range.Copy Destination:=ws_new_init.Range("A1")
fac_onsite_range.Copy Destination:=ws_new_fac.Range("A1")
ThisWorkbook.VBProject.VBComponents(ws_new_init.CodeName).CodeModule.AddFromString code_line
ThisWorkbook.VBProject.VBComponents(ws_new_fac.CodeName).CodeModule.AddFromString code_line
Next counter
End If
ws_config.Activate
MsgBox Str(facility_count) & " facilities added"
End Sub

Related

Troubleshoot "Unable to get the Buttons property of the Worksheet class"?

I created a 7-sheet Excel spreadsheet as a test-help companion to a popular bridge book by Kantar called "Modern Bridge Defense". The spreadsheet has a fairly large number of form buttons that allow a user to show or hide test answers from each of the seven chapters in the book
I have vba code that shows or hides the answer text, depending on the caption ('show' or 'hide') of the associated button, and a 'show/hide all' button that will show or hide all answers associated with a particular section of that chapter's test.
I also have vba code that initializes all the buttons on all 7 sheets. When the user first opens the spreadsheet, he/she is asked if they are OK with hiding all the answers. If they agree, the initialization routine loops through all 7 sheets, and the code for each sheet loops through all the buttons on that sheet, hiding each answer that isn't already hidden.
All this works fine if I step through the buttons in debug mode, but fails with "Unable to get the Buttons property of the Worksheet class" at some point (not always the same point) when I try to run it full speed.
This behavior seems like it might be some sort of timing/race issue, but I'm having trouble imagining how that could be, as I don't think I'm really tasking my laptop (XPS15 7590 with 32GB Ram, 1TB SSD).
Here is my initialization routine and the function it calls to iterate through the sheet buttons:
Option Explicit
Private Sub Workbook_Open()
Debug.Print ("In Workbook_Open()")
Dim res As VbMsgBoxResult
res = MsgBox("Hide all answers?", vbYesNoCancel, "Kantar Test Initialization")
If res = vbYes Then
res = MsgBox("Caution! This action will hide all answers - Are you SURE you want to do this?", vbYesNoCancel, "Are you SURE?")
If res = vbYes Then
'OK, user is sure about doing this!
Dim sheet As Worksheet
For Each sheet In Application.Sheets
Debug.Print "Initializing worksheet " & sheet.Name
On Error Resume Next
InitializeAllButtons sheet
If Err <> 0 Then
Debug.Print "call to InitializeAllButtons)" & sheet.Name & " failed with " & Err.Description
End If
Next sheet
End If
End If
End Sub
and here's the function that actually 'clicks' the buttons
Sub InitializeAllButtons(sheet As Worksheet)
Dim btn As Excel.Button, addrstr, startcellstr, startrowstr, endrowstr, colstr As String
Dim pos As Integer
Dim startrow As Integer
Dim endrow As Integer
Dim col As Integer
Dim rownum As Integer
With sheet
For Each btn In .Buttons
Debug.Print (vbTab & btn.Name & ", " & btn.Caption)
'11/27/22 rev to set 'all' button captions to 'Hide All', click on all 'Hide' row buttons
If InStr(btn.Caption, "All") > 0 Then
btn.Caption = "Show All"
Debug.Print "btn " & btn.Name & " caption changed to Show All"
Else 'is normal row show/hide button
If btn.Caption = "Hide" Then
RowButtonClick (btn.Name)
End If
End If
Next
End With
End Sub
In response to a question, here is the 'RowButtonClick()' function
Function RowButtonClick(btn_name As String) As Integer
Dim btn As Excel.Button
Dim btn_text As String
Dim cellstr As String
Dim row, col As Integer
Dim textrange As Range
'for multiple row show/hide ops
Dim cellstrlen As Integer
Dim startrowstr, endrowstr, startcolstr As String
Dim startrow As Integer
Dim endrow As Integer
Dim charidx As Integer
'11/24/22 multiple row button names include '_'
charidx = InStr(btn_name, "_")
If charidx > 0 Then
'11/24/22 row addresses may be 1, 2, or 3 digits
GetStartEndRowCol btn_name, startrow, endrow, col
Debug.Print ("RBC just after GSER: start row = " & startrow & ", end row = " & endrow)
Else 'single row: endrow = startrow
cellstr = Mid(btn_name, 9)
startrow = Range(cellstr).row
endrow = startrow
col = Range(cellstr).Column
Debug.Print "RBC: Single row show/hide action"
End If
Set btn = Application.ActiveSheet.Buttons(btn_name)
btn_text = btn.Caption
With Application.ActiveSheet
If btn_text = "Show" Then
Application.ActiveSheet.Range(.Cells(startrow, col + 1), .Cells(endrow, col + 2)).NumberFormat = ""
btn.Caption = "Hide"
Else
Application.ActiveSheet.Range(.Cells(startrow, col + 1), .Cells(endrow, col + 2)).NumberFormat = "; ; ;"
btn.Caption = "Show"
End If
End With
RowButtonClick = endrow 'so calling fcn knows the next row to try
End Function

Fill shape data field from external data

I'm trying to link shape data field from external data like excel.
As #JohnGoldsmith suggested I used DropLinked but "I'm getting object name not found" error.
My main agenda is drop multiple shapes on drawing with shape data field "Name", then fill all the shape data field using external data in order. I also used spatial search for dropping shapes on drawing(Thanks to #Surrogate). By the way I'm using Visio Professional 2019.
It's often a good plan to separate chained members so you can identify whether (as #Paul points out) you're having a problem getting to the stencil or the master.
Following is a modified example of link shapes to data. I've ditched all of the spatial search stuff as I think that's a separate issue. If you still have trouble with that I would ask another question and narrow your sample code to not include the data linking part - ie just drop shapes and try and change their position. Bear in mind there's also Page.Layout and Selection.Layout
I think you've got the adding the DataRecordsets in the other linked question, so this example makes the following assumptions:
You have a drawing document open
You have the "Basic Shapes" stencil open (note my version is metric "_M")
You have a DataRecordset applied to the document named "AllNames"
The above record set has a column named "Name" that contains the data you want to link
Public Sub ModifiedDropLinked_Example()
Const RECORDSET_NAME = "AllNames"
Const COL_NAME = "Name"
Const STENCIL_NAME = "BASIC_M.vssx"
Const MASTER_NAME = "Rectangle"
Dim vDoc As Visio.Document
Set vDoc = Application.ActiveDocument
Dim vPag As Visio.Page
Set vPag = Application.ActivePage
Dim vShp As Visio.Shape
Dim vMst As Visio.Master
Dim x As Double
Dim y As Double
Dim xOffset As Double
Dim dataRowIDs() As Long
Dim row As Long
Dim col As Long
Dim rowData As Variant
Dim recordset As Visio.DataRecordset
Dim recordsetCount As Integer
For Each recordset In vDoc.DataRecordsets
If recordset.Name = RECORDSET_NAME Then
dataRowIDs = recordset.GetDataRowIDs("")
xOffset = 2
x = 0
y = 2
Dim vStencil As Visio.Document
Set vStencil = TryFindDocument(STENCIL_NAME)
If Not vStencil Is Nothing Then
Set vMst = TryFindMaster(vStencil, MASTER_NAME)
If Not vMst Is Nothing Then
For row = LBound(dataRowIDs) + 1 To UBound(dataRowIDs) + 1
rowData = recordset.GetRowData(row)
For col = LBound(rowData) To UBound(rowData)
Set vShp = vPag.DropLinked(vMst, x + (xOffset * row), y, recordset.ID, row, False)
Debug.Print "Linked shape ID " & vShp.ID & " to row " & row & " (" & rowData(col) & ")"
Next col
Next row
Else
Debug.Print "Unable to find master '" & MASTER_NAME & "'"
End If
Else
Debug.Print "Unable to find stencil '" & STENCIL_NAME & "'"
End If
Else
Debug.Print "Unable to find DataRecordset '" & RECORDSET_NAME & "'"
End If
Next
End Sub
Private Function TryFindDocument(docName As String) As Visio.Document
Dim vDoc As Visio.Document
For Each vDoc In Application.Documents
If StrComp(vDoc.Name, docName, vbTextCompare) = 0 Then
Set TryFindDocument = vDoc
Exit Function
End If
Next
Set TryFindDocument = Nothing
End Function
Private Function TryFindMaster(ByRef vDoc As Visio.Document, mstNameU As String) As Visio.Master
Dim vMst As Visio.Master
For Each vMst In vDoc.Masters
If StrComp(vMst.NameU, mstNameU, vbTextCompare) = 0 Then
Set TryFindMaster = vMst
Exit Function
End If
Next
Set TryFindMaster = Nothing
End Function
The above code drops six shapes onto the page and adds a Shape Data row (Prop._VisDM_Name) with the corresponding data value. If you want the name text to appear in the shape then you would normally modify the master with an inserted field in the shape's text. (If you get stuck with this part then ask another question.)
One last point is that this example loops through the DataRecordset rows dropping a shape for each one, but there is also a Page.DropManyLinkedU method that allows you to this en masse.

VBA to extract file information, add any new information after last row of data

Sub GetFileList()
Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim objOL As Object
Dim Msg As Object
Dim xPath As String
Dim thisFile As String
Dim i As Integer
Dim lastrow As Long
xPath = Sheets("UI").Range("D7")
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
i = 1
For Each xFile In xFolder.Files
i = i + 1
Worksheets("Info").Cells(i, 1) = xPath
Worksheets("Info").Cells(i, 2) = Left(xFile.Name, InStrRev(xFile.Name, ".") - 1)
Worksheets("Info").Cells(i, 3) = Mid(xFile.Name, InStrRev(xFile.Name, ".") + 1)
Worksheets("Info").Cells(i, 6) = Left(FileDateTime(xFile), InStrRev(FileDateTime(xFile), " ") - 1)
Next
Set Msg = Nothing
Worksheets("Info").Visible = True
Worksheets("Info").Activate
End Sub
The code to extract file information from a folder. The issue is when I change the folder path, it overwrites on the previously fetched data.
Sheet -UI is where the sub executed on press of button, Sheet Info is the place where the data needs to be pasted.
How to write the code to add a new row of data after the data which is already available. If the sheet is blank then add data from the 1st ROW otherwise add data from the LAST ROW.
Sheets("UI").Range("A1").End(xlDown).Select
i = Selection.Row + 1
Try replacing
i = 1
with
i = Worksheets("Info").UsedRange.Rows.Count + 1
This will set i to 1 the first time around, and to the first free row ever after. New data will be added below the existing data, if there is any.

Exporting Access query results by record to new worksheet in file

I'm trying to workout how to split the unique records of a query to new worksheets in the same excel workbook (template file). My access query has the following fields:
Project Number,Project Name,Task Number,Project Sponsor,Full Year Budget,APR,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec,Jan,Feb,Mar,Full,Year Forecast.
I want to be able to have a new worksheet for each Project Number and list the relevant data, and also rename the worksheet as the Project Number...I have a complete mind block after spending hours playing around with other code for similar requests, but cannot get anything to behave the way I need it to?
Does any one have a ideas or could point me in the right direction, I'm not a complete novice at vba but this one has me well and truly stuck.
Many thanks :)
Hi All, thanks for the suggestions, I've managed to cobble together the code to spilt the data and export to individual worksheets and its working ok.I now need to copy over any associated data from another query to the relevant worksheet in a "table" below the other data, but I'm not having much luck. Either it will copy one record to one of the worksheets or all of the records to a single worksheet irrespective. Can anyone point me in the right direction?
Option Compare Database
Global iter As Integer
Sub Loop_Practice2()
Dim rs As DAO.Recordset
Dim ProjectNumber As DAO.Recordset
Dim i As Integer
Dim j As Integer
Dim Worksheet_Count As Integer
Dim sSql As String
Dim Project_Count As Integer
Dim iCol As Integer
Dim mypath As String
Dim mvalue As String
Dim myfile As String
Dim mynewfile As String
Dim mynewpath As String
Dim wb As Excel.Workbook
Dim WS As Excel.Worksheet
Dim sFile As String
mypath = Application.CurrentProject.Path & "\"
myfile = ("PIN Export Template.xlsx")
mynewpath = (Application.CurrentProject.Path & "\")
mynewfile = ("PIN Export Template.xlsx - " & Format(Now(), "yyyy-mm-dd") & ".xlsx")
sFile = mypath & myfile
' ' Use Dir to check if file exists
If Dir(sFile) = "" Then
' if file does not exist display message
MsgBox "Could not find the file " & sFile & " - Please ensure it is in the same location as the database."
Exit Sub
End If
'Open Excel
Excel.Application.Visible = True
Excel.Application.Workbooks.Open (sFile)
'Define Access Query to be exported
Set ProjectNumber = CurrentDb.OpenRecordset("SELECT DISTINCT qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly.[Project Number] from qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly")
If ProjectNumber.EOF Then Exit Sub
ProjectNumber.MoveLast
Project_Count = ProjectNumber.RecordCount - 1
ProjectNumber.MoveFirst
'Create individual PIN sheets from Query Dataset
Excel.Application.Worksheets("PIN").Select
Worksheet_Count = Excel.Application.Worksheets("PIN").Select
Do Until Worksheet_Count = Project_Count
Worksheets("PIN").Copy After:=Worksheets("PIN")
If iter = 0 Then
iter = 1
End If
ActiveSheet.Name = ("PIN") & iter
iter = iter + 1
Worksheet_Count = Worksheet_Count + 1
Loop
j = 1
'Add qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly data
Do Until ProjectNumber.EOF
sSql = "SELECT *"
sSql = sSql & " FROM qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly"
sSql = sSql & " Where qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly.[Project Number]=" & ProjectNumber("[Project Number]")
Set rs = CurrentDb.OpenRecordset(sSql, dbOpenDynaset)
Set Pin_Sheet = ActiveWorkbook.Sheets("PIN" & j)
'Rename the PIN sheet to individual Project Number
Pin_Sheet.Name = ProjectNumber("[Project Number]")
'Create PIN Analysis Column Headings
For iCol = 0 To rs.Fields.Count - 1
Pin_Sheet.Cells(13, iCol + 4).Value = rs.Fields(iCol).Name
Next
'Populate PIN_Analysis_Step_01_FY_Position_Monthly Data
Pin_Sheet.Cells(14, 4).CopyFromRecordset rs
j = j + 1
ProjectNumber.MoveNext
Loop
Excel.Application.ActiveWorkbook.SaveAs (mynewpath & mynewfile)
Set Pin_Sheet = Nothing
Set ProjectNumber = Nothing
Set ProjectNumber2 = Nothing
Set rs = Nothing
Set ProjectNumber = Nothing
Set wb = Nothing
Set WS = Nothing
CurrentDb.Close
ActiveWorkbook.Close
Excel.Application.Quit
End Sub
AS 'Erik von Asmuth' Suggested it is a broad question split into a different task and share your code. what you have attempted until now.
I can only point you to one article written by Daniel Pineault . He had created a function called ExportRecordset2XLS through which you can pass your recordset, Sheet Name etc.
you have to create a loop for different project number and pass as an argument to this function. you also need to modify this code to handle differnt task as per your requiremnts.
https://www.devhut.net/2017/03/15/ms-access-vba-export-recordset-to-excel/

Range constraint and variable management when passing information from macro to userform to worksheet

I've built a userform that allows modification of a macro-generated string before it becomes part of a new spreadsheet. As written, I have one worry about how resilient it will be.
The form has a single textbox called CourseDescription into which a string value strBundleDescription is dumped:
frmDescriptionReview.CourseDescription = strBundleDescription
frmDescriptionReview.CourseDescription.MultiLine = True
frmDescriptionReview.CourseDescription.WordWrap = True
frmDescriptionReview.Show
The user can then edit the text as needed and press OK to pass the text to the spreadsheet being created.
On clicking OK, the modified string is placed in Range("B7") of the spreadsheet:
Private Sub cmdOK_Click()
Dim strValue As String
strValue = CourseDescription.Value
If strValue <> "" Then
Range("B7").Value = strValue
End If
Unload Me
End Sub
This works so far in practice, but I've had unexplained focus issues before. I am concerned that the focus might in some (unknown) circumstance shift to another open worksheet and the text will be pasted where it does not belong.
My question: Am I right to want a more defined location, or will a simple range definition like the one above be adequate? And if a more defined location is advised, is there a way to pass information like the wkbSaba and shtCourse values without making public variables?
All potential solutions I found involved some form of public variable, but on principle (rightly or wrongly) I'm trying to avoid public variables when information will only be used in one function (as in this case).
Full Code, as requested: This is the the full macro code as it stands. The call for frmDescriptionReview is about 3/4 of the way down under the comment tag "'enter base information for Bundle Description".
I'm going to try the Property call as you suggest, which is something I did not know about, and had not seen when web searching for ways to pass data to a userform. So much to learn! It certainly looks like the variables could be passed that way.
Option Explicit
Sub TransferData()
'***************************************
' TO USE THIS MACRO:
' 1. Make sure that all information for the bundle is included
' on the 'km notification plan' and 'bundle details (kbar)' tabs
' of the Reporting_KMFramework.xlsx
' 2. Select the bundle name on the 'km notification plan' tab.
' 3. Start the macro and it should create the basis of the Saba
' form
' 4. Read through the entire form, especially the bundle
' description, to be sure it is complete and accurate.
'***************************************
'establish variables
Dim iRow As Integer
Dim sTxt As String
Dim sTxt2 As String
Dim sBundleName As String
Dim sNumber As String
Dim aSplit() As String
Dim aSplit2() As String
Dim aBundleSplit() As String
Dim aNumberSplit() As String
Dim wkbFramework As Workbook
Dim wkbSaba As Workbook
Dim shtPlan As Worksheet
Dim shtCourse As Worksheet
Dim vData As Variant
Dim vBundleName As Variant
Dim lLoop As Long
'set initial values for variables
'find current row number
iRow = ActiveCell.Row
'remember locations of current data
Set wkbFramework = ActiveWorkbook
Set shtPlan = ActiveSheet
'Set rngSelect = Range("B" & iRow)
'select bundle name
vBundleName = shtPlan.Range("B" & iRow).Value
vData = vBundleName
sBundleName = shtPlan.Range("B" & iRow).Value
'find and save course names for the bundle
Sheets(2).Select
sTxt = Find_Range(vBundleName, Columns("B"), xlValues).Offset(0, 1).Value 'course names from Detail tab
sTxt2 = Find_Range(vBundleName, Columns("B"), xlValues).Offset(0, 2).Value 'course numbers from Detail tab
'open new Saba Form
Workbooks.Add Template:= _
"C:\Documents and Settings\rookek\Application Data\Microsoft\Templates\Bundle_SabaEntryForm_KM.xltm"
'remember locations of Saba form
Set wkbSaba = ActiveWorkbook
Set shtCourse = ActiveSheet
'move data into new Saba form
'paste bundle name
wkbSaba.Sheets(shtCourse.Name).Range("B5").Value = vData
'Transfer bundle number
vData = wkbFramework.Sheets(shtPlan.Name).Range("E" & iRow).Value
sNumber = vData
Dim aNumber() As String
aNumber = Split(sNumber, "-")
wkbSaba.Sheets(shtCourse.Name).Range("B6").Value = vData
'create names to use in the bundle description and (later) in naming the file
'Establish additional variables
Dim strDate As String
Dim strName1 As String
Dim strName2 As String
Dim strName3 As String
Dim strName4 As String
Dim strName5 As String
Dim aTechSplit() As String
Dim aCourse() As String
Dim iTech As Integer
'Dim iBundle As Integer
Dim iCourse As Integer
vData = wkbFramework.Sheets(shtPlan.Name).Range("L" & iRow).Value
aCourse = Split(sTxt, Chr(10))
iCourse = UBound(aCourse)
aTechSplit = Split(vData, " ")
iTech = UBound(aTechSplit)
aBundleSplit = Split(sBundleName, " ")
aNumberSplit = Split(sNumber, "-")
strName1 = aBundleSplit(0)
strName2 = aBundleSplit(1)
If UBound(aNumberSplit) > 1 Then
strName3 = aNumberSplit(UBound(aNumberSplit) - 1) & aNumberSplit(UBound(aNumberSplit))
End If
strName3 = Right(strName3, Len(strName3) - 1)
strName4 = aTechSplit(0) & " "
strName5 = aCourse(0)
For lLoop = 1 To iTech - 1
strName4 = strName4 & aTechSplit(lLoop) & " "
Next lLoop
If iCourse > 1 Then
For lLoop = 1 To iCourse - 1
strName5 = strName5 & ", " & aCourse(lLoop)
Next lLoop
strName5 = strName5 & ", and " & aCourse(iCourse)
End If
If iCourse = 1 Then
strName5 = strName5 & ", and " & aCourse(iCourse)
End If
strName5 = Replace(strName5, " Technical Differences", "")
strName5 = Replace(strName5, " Overview", "")
strName5 = Replace(strName5, " Technical Presales for ATCs", "")
strName5 = Replace(strName5, " Technical Presales for STCs", "")
strName5 = Replace(strName5, " Technical Presales", "")
'enter base information for Bundle Description
Dim strBundleDescription As String
strBundleDescription = "This Knowledge Maintenance bundle covers recent technology changes that may affect " & strName4 & "environments. Topics covered by this bundle include the enhancements and features introduced with " & strName5 & "."
'wkbSaba.Sheets(shtCourse.Name).Range("B7").Value = strBundleDescription
frmDescriptionReview.CourseDescription = strBundleDescription
frmDescriptionReview.CourseDescription.MultiLine = True
frmDescriptionReview.CourseDescription.WordWrap = True
frmDescriptionReview.Show
'transfer tech and track
wkbSaba.Sheets(shtCourse.Name).Range("B8").Value = vData
'transfer product GA date
vData = wkbFramework.Sheets(shtPlan.Name).Range("G" & iRow).Value
wkbSaba.Sheets(shtCourse.Name).Range("B9").Value = vData
'transfer bundle notification date
vData = wkbFramework.Sheets(shtPlan.Name).Range("D" & iRow).Value
wkbSaba.Sheets(shtCourse.Name).Range("B10").Value = vData
'set audience type
If aNumber(UBound(aNumber)) = "SA" Then
wkbSaba.Sheets(shtCourse.Name).Range("B11").Value = "Internal, Partner, Customer"
Else
wkbSaba.Sheets(shtCourse.Name).Range("B11").Value = "Internal, Partner"
End If
'set Education Manager
frmEducationManagerEntry.EducationManagers.MultiLine = True
frmEducationManagerEntry.EducationManagers.WordWrap = True
frmEducationManagerEntry.Show
'set EPG
wkbSaba.Sheets(shtCourse.Name).Range("B13").Value = "N/A (KM course reuse)"
'set Test information to N/A
wkbSaba.Sheets(shtCourse.Name).Range("A22:B22").Value = "N/A"
'enter course names
aSplit = Split(sTxt, Chr(10)) 'if there is more than one course, this establishes a number and location for each
If UBound(aSplit) > 4 Then
'add rows equal to the difference between ubound and 5
wkbSaba.Sheets(shtCourse.Name).Range("A21", "B" & 21 + (UBound(aSplit) - 5)).Select
Selection.EntireRow.Insert
End If
For lLoop = 0 To UBound(aSplit)
wkbSaba.Sheets(shtCourse.Name).Range("B" & 17 + lLoop).Value = aSplit(lLoop)
Next lLoop
'enter course numbers
aSplit2 = Split(sTxt2, Chr(10)) 'if there is more than one course, this establishes a number and location for each
For lLoop = 0 To UBound(aSplit2)
wkbSaba.Sheets(shtCourse.Name).Range("A" & 17 + lLoop).Value = Trim(aSplit2(lLoop))
Next lLoop
'save and close Saba form
With wkbSaba.Sheets(shtCourse.Name)
Dim SaveAsDialog As FileDialog
strDate = Date
strDate = Replace(strDate, "/", ".")
Set SaveAsDialog = Application.FileDialog(msoFileDialogSaveAs)
With SaveAsDialog
.Title = "Choose a file location and file name for your new Saba form"
.AllowMultiSelect = False
.InitialFileName = strName1 & strName2 & "_SabaEntryForm_" & strName3 & ".xlsx"
'.InitialFileName = sSavelocation & "\" & strName3 & "\" & aBundleSplit(0) & aBundleSplit(1) & "_" & strName3 & "_SabaEntryForm" & ".xlsx"
.Show
.Execute
End With
wkbSaba.Sheets(shtCourse.Name).PrintOut
wkbSaba.Close
End With
' Return focus to Plan sheet
shtPlan.Activate
End Sub
Addition of Property code fails
I tried adding code based on the property link shared in the comments, but running the code results in a Compile error: Method or data member not found. The complete userform code looks like this:
Option Explicit
Private wkbLocation As Workbook
Private shtLocation As Worksheet
Private Sub cmdCancel_Click()
Unload Me
End
End Sub
Private Sub cmdOK_Click()
Dim strValue As String
strValue = CourseDescription.Value
If strValue <> "" Then
wkbLocation.Sheets(shtLocation).Range("B7").Value = strValue
End If
Unload Me
End Sub
Property Let MyProp(wkbSaba As Workbook, shtCourse As Worksheet)
wkbLocation = wkbSaba
shtLocation = shtCourse
End Property
And the call for the userform now looks like this:
'enter base information for Bundle Description
Dim strBundleDescription As String
strBundleDescription = "This Knowledge Maintenance bundle covers recent technology changes that may affect " & strName4 & "environments. Topics covered by this bundle include the enhancements and features introduced with " & strName5 & "."
'wkbSaba.Sheets(shtCourse.Name).Range("B7").Value = strBundleDescription
Dim frmDescriptionReview As UserForm3
Set frmDescriptionReview = New UserForm3
frmDescriptionReview.MyProp = "Pass to form"
frmDescriptionReview.CourseDescription = strBundleDescription
frmDescriptionReview.CourseDescription.MultiLine = True
frmDescriptionReview.CourseDescription.WordWrap = True
frmDescriptionReview.Show
When I run the code, I get a Compile error: Method or data member not found, highlighting .MyProp. Help says this error means I misspelled the object or member name, or specified a collection index that is out of range. I checked the spelling, and MyProp is exactly how I spelled it in both locations. I don't think I'm specifying a collection am I? None are explicitly defined. What am i doing wrong?
I am concerned that the focus might in some (unknown) circumstance
shift to another open worksheet and the text will be pasted where it
does not belong.
Not really sure what you are asking. But you can further define your range variable by using:
Workbooks("Book1.xlsm").Worksheets("Sheet1").Range("B7").Value = strValue
or
Workbooks(wkbSaba).Worksheets(shtCourse).Range("B7").Value = strValue
That will ensure it goes to the right workbook and worksheet. I'm not sure why you think you need public variables?
EDIT:
UserForm Code:
Private wsSheet As Worksheet
Property Let SetWorksheet(wsSheetPass As Worksheet)
Set wsSheet = wsSheetPass
End Property
Private Sub cmdOK_Click()
Dim strValue As String
strValue = CourseDescription.Value
If strValue <> "" Then
wsSheet.Range("B7").Value = strValue
End If
Unload Me
End Sub
Calling Module:
Dim wsSheetToPass As Worksheet
Set wsSheetToPass = Workbooks(wkbSaba).Worksheets(shtCourse)
frmDescriptionReview.SetWorksheet = wsSheetToPass
As Reafidy states, creating a Property for the Userform and passing information to it would clearly be the right answer for passing variables to and from a userform.
Ideally what I want is to have the form very losely coupled with the module, and not touch the spreadsheet at all (so when appropriate I can pass information to the form from other modules, get the information returned, and place it where appropriate for the current module (which could be on an entirely different spreadsheet or in a completely different cell).
I found additional information on passing data with properties on the PeltierTech web site (http://peltiertech.com/Excel/PropertyProcedures.html) that helped me understand what Reafidy was doing so I couls start loosening the coupling between my code and my forms even more (which was my original intent for this question.
Adding the Get property allows the loose coupling I'm looking for, allowing me to both give and receive information without having to pass the spreadsheet data at all. So my call in the module now looks like this:
'review and revise Description Text
Dim DescriptionReview As New frmDescriptionReview
With DescriptionReview
.Description = strBundleDescription
.Show
strBundleDescription = .Description
End With
Unload DescriptionReview
'transfer description text
wkbSaba.Sheets(shtCourse.Name).Range("B7").Value = strBundleDescription
and the code for the UserForm itself becomes much simpler, like this:
Option Explicit
Property Let Description(ByVal TextBeingPassed As String)
Me.CourseDescription.Value = TextBeingPassed
End Property
Property Get Description() As String
Description = Me.CourseDescription.Value
End Property
Private Sub cmdOK_Click()
Me.Hide
End Sub
Private Sub cmdCancel_Click()
Unload Me
End
End Sub

Resources