I'm trying to take a table of data from Excel and import it into MS Project
Here is a screenshot of what I have in Excel:
CC: Excel table of column headers of: WBS, Task Name, Start Date, Finish Date, Duration, Work, and Resource Name with rows of data that are independent of resource name assignment.
Here is a screenshot of what I am looking for a VBA code to be able to produce from Excel to MS Project:
CC: MS Project file showing columns of WBS, Task Name, Start Date, Finish Date, Duration, Work, and Resource Name with resource names grouped by WBS.
I've tried copy and paste, but there has got to be a better option with VBA (I hope?)
If there are questions, I'm happy to answer them.
I really appreciate any help anyone can give me!
EDIT:
Here is the VBA I have now:
Sub ExceltoProject()
Dim pjapp As Object
Dim strValue, strStartDate, strEndDate, Strresource As String
Dim newproj
Set pjapp = CreateObject("MSProject.Application")
If pjapp Is Nothing Then
MsgBox "Project is not installed"
Exit Sub
End If
pjapp.Visible = True
Set newproj = pjapp.Projects.Add
newproj.Title = "ExcelExtract"
Set ActiveProject = newproj
For i = 2 To 4
strWBS = Worksheets("LABOR_IMS_INPUT").Range("A" & i)
strTaskName = Worksheets("LABOR_IMS_INPUT").Range("B" & i)
strStartDate = Worksheets("LABOR_IMS_INPUT").Range("C" & i)
strEndDate = Worksheets("LABOR_IMS_INPUT").Range("D" & i)
strDuration = Worksheets("LABOR_IMS_INPUT").Range("E" & i)
Strresource = Worksheets("LABOR_IMS_INPUT").Range("F" & i)
strWork = Worksheets("LABOR_IMS_INPUT").Range("G" & i)
newproj.Tasks.Add (strValue & " " & Strresource)
newproj.Resources.Add.Name = Strresource
newproj.Tasks(i - 1).ResourceNames = Strresource
Next i
End Sub
Public Function ExistsInCollection(pColl, ByVal pKey As String) As Boolean
On Error GoTo NoSuchKey
If VarType(pColl.Item(pKey)) = vbObject Then
' force an error condition if key does not exist
End If
ExistsInCollection = True
Exit Function
NoSuchKey:
ExistsInCollection = False
End Function
But this is what I get:
CC: Excel file and MS Project file. MS Project file only has "resource sheet name" data.
Any ideas what is happening. That I'm doing wrong?
Sorry for previous issues with clarity, I am visually impaired and trying to code!
This code will take the data from the Excel sheet to create a new Project schedule. No need to set both Finish and Duration fields as the Finish date will be determined by the Start date and Duration.
Sub ExceltoProject()
Dim pjapp As Object
Dim newproj As Object
Set pjapp = CreateObject("MSProject.Application")
If pjapp Is Nothing Then
MsgBox "Project is not installed"
Exit Sub
End If
pjapp.Visible = True
Set newproj = pjapp.Projects.Add
newproj.Title = "ExcelExtract"
Dim wst As Worksheet
Set wst = ThisWorkbook.Worksheets("LABOR_IMS_INPUT")
Dim i As Long
For i = 2 To 4
newproj.Tasks.Add
newproj.Tasks(i - 1).Name = wst.Cells(i, 2)
newproj.Tasks(i - 1).WBS = wst.Cells(i, 1)
newproj.Tasks(i - 1).Start = CDate(wst.Cells(i, 3))
newproj.Tasks(i - 1).Duration = wst.Cells(i, 5) & "d"
newproj.Tasks(i - 1).ResourceNames = wst.Cells(i, 7)
newproj.Tasks(i - 1).Work = wst.Cells(i, 6) & "h"
Next i
End Sub
Related
I'm trying to create an Excel spreadsheet from MS Project that will iterate through the project start to finish dates, & for each date (in ascending sequence from the start) output the amount of work hours each resource is assigned for each task that is scheduled to take place on that day, like this:
Excel output from MS Project
I've almost managed to get it working to some extent, but am struggling with showing the number of hours worked PER DAY, as opposed to the whole amount of work hours for the task (which is what it's currently doing).
Option Explicit
Sub exportViaArray()
' Declare in memory
Dim xl As Excel.Application
Dim XLbook As String
Dim xlRange As Excel.Range
Dim tsk As Task
Dim tsksList As Tasks
Dim person As Resource
Dim resList As Resources
Dim prjStart As Date, prjFinish As Date, prjDate As Date, dateLoop As Date, dateArray() As Date
Dim counter As Integer
Dim totalDates As Long
Dim day As Variant
' Define variable values
prjStart = ActiveProject.ProjectStart
prjFinish = ActiveProject.ProjectFinish
Set tsksList = ActiveProject.Tasks
Set resList = ActiveProject.Resources
' assigning the project start date for loop var prjDate
prjDate = prjStart
' assign specific dates, for dev/testing
prjStart = "02/12/2022 08:00:00"
prjFinish = "22/12/2022 08:00:00"
' prjDate = "12/12/2022 08:00:00"
' create an array of dates to iterate through
totalDates = DateDiff("d", prjStart, prjFinish)
ReDim dateArray(totalDates)
counter = 0
dateLoop = prjStart
Do While dateLoop 0 Then
On Error GoTo 0
Set xl = CreateObject("Excel.Application")
If Err 0 Then
MsgBox "Excel application is not available on this workstation" _
& vbCr & "Install Excel or check network connection", vbCritical, _
"Notes Text Export - Fatal Error"
FilterApply Name:="all tasks"
Set xl = Nothing
On Error GoTo 0 'clear error function
Exit Sub
End If
End If
On Error GoTo 0
xl.Workbooks.Add
XLbook = xl.ActiveWorkbook.Name
' Keeping these True for dev/testing
xl.Visible = True
xl.ScreenUpdating = True
xl.DisplayAlerts = True
ActiveWindow.Caption = " Writing data to worksheet"
' Excel - create column headings
Set xlRange = xl.Range("A1")
xlRange.Range("A1") = "Date"
xlRange.Range("B1") = "Resource"
xlRange.Range("C1") = "Duration"
' Set all column headers
With xlRange.Range("A1:C1")
.Font.Bold = True
.VerticalAlignment = xlVAlignCenter
End With 'XLrange
' Export Schedule Report Information
Set xlRange = xlRange.Range("A2")
' date iterator
Do While prjDate "" Then
With xlRange
.Range("A1") = Format(tsk.Start, "short Date")
.Range("B1") = tsk.ResourceNames
.Range("C1") = tsk.Duration
End With
' Go to next row in Excel
Set xlRange = xlRange.Offset(1, 0)
End If
Next tsk
'increment date
prjDate = DateAdd("d", 1, prjDate)
'check current loop date is not greater than end date
If prjDate > prjFinish Then
Exit Do
End If
Loop
xlRange.Range("A1:C1").EntireColumn.AutoFit
Set xl = Nothing
' Reset window to project name
ActiveWindow.Caption = ActiveProject.Name
End Sub
I'm not a developer, but can generally hack stuff together to get a result, & I'm sure there's errors in the above, but this last piece of the puzzle has really got me.
I was hoping it'd be something along the lines of using something like this: day.task.resource.work but I've tried & can't get that to work.
Any help would be greatly appreciated.
Cheers!
Derrick, you need to export timescaled data (i.e. Project's Resource Usage view). It sounds like you are trying to export static data. This code should get you started with a few tweaks to export resource hours instead of % allocation. I'll leave that as an "exercise for the student." But, if you need more help, I'll be available.
'Exports resource and assignment percent allocation
'Author: John-Project
'Initial release: 7/6/21 11:00 AM
Option Explicit
Public Const ver = " 1.0"
Public xl As Excel.Application
Public WS1 As Worksheet, WS2 As Worksheet
Public xlRange As Range
Public TotMon As Integer
Public PrSt As Date, PrFi As Date, Dat As Date
Public i As Integer, j As Integer, p1 As Integer, Delta As Integer
Public k As Long, TimSt As Long, TotTim As Long
Sub ExportFTEdata()
Dim r As Resource
Dim a As Assignment
Dim ResSt As Date, ResFin As Date
Dim TSV1 As TimeScaleValues
'opening user interface
MsgBox "This macro exports Monthly FTE data (% Allocation)" & vbCr _
& "by resource and resource assignments to a new Excel Workbook." & vbCr _
& vbCr & "When complete the user will be shown an Excel Save As prompt", _
vbInformation, "Timescale Export - ver" & ver
'find start and finish of plan to establish index reference for weekly values
PrSt = ActiveProject.ProjectStart
PrFi = ActiveProject.ProjectFinish
TotMon = DateDiff("m", PrSt, PrFi)
'set up an new instance of Excel, or if Excel is not running, start it
On Error Resume Next
Set xl = GetObject(, "Excel.application")
If Err <> 0 Then
On Error GoTo 0
Set xl = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Excel application is not available on this workstation" _
& vbCr & "Install Excel or check network connection", vbCritical, _
"Project Data Export - Fatal Error"
FilterApply Name:="all tasks"
Set xl = Nothing
On Error GoTo 0 'clear error function
Exit Sub
End If
End If
On Error GoTo 0
'create a workbook with two worksheets
xl.Workbooks.Add
xl.ActiveWorkbook.Worksheets(1).Name = "FTE Data"
Set WS1 = xl.ActiveWorkbook.Worksheets(1)
'Keep Excel in the background and minimized until spreadsheet is done (speeds transfer)
xl.Visible = True
xl.ScreenUpdating = True
xl.DisplayAlerts = False
TimSt = Timer 'capture start time of export
'pre-format worksheet
ShFormat1
'Populate monthly data worksheet
Set xlRange = WS1.Range("C2")
'initialize worksheet row counter
i = 0
For Each r In ActiveProject.Resources
xlRange.Offset(i, -2) = r.Name
If r.Assignments.Count > 0 Then
'resource start and finish fields are not directly readable with VBA
' so need to cycle through all assignments and find earliest and latest
ResSt = "12/31/2049": ResFin = "1/1/1984"
For Each a In r.Assignments
If a.Start < ResSt Then ResSt = a.Start
If a.Finish > ResFin Then ResFin = a.Finish
Next a
'determine resource start offset from project start
Delta = DateDiff("m", PrSt, ResSt)
'write monthly percent allocation values for resource
Set TSV1 = r.TimeScaleData(StartDate:=ResSt, EndDate:=ResFin, _
Type:=pjResourceTimescaledPercentAllocation, timescaleunit:=pjTimescaleMonths)
p1 = Delta 'set column start pointer
For k = 1 To TSV1.Count
If IsNumeric(TSV1(k)) Then
xlRange.Offset(i, p1).Value = Round(TSV1(k).Value, 0) & "%"
End If
p1 = p1 + 1
Next k
'increment row and reset start pointer
i = i + 1
'write monthly percent allocation vlaues for assignments
For Each a In r.Assignments
'reset start pointer for this assignment
Delta = DateDiff("m", PrSt, a.Start)
p1 = Delta
xlRange.Offset(i, -1).Value = a.TaskName
Set TSV1 = a.TimeScaleData(StartDate:=a.Start, EndDate:=a.Finish, _
Type:=pjAssignmentTimescaledPercentAllocation, timescaleunit:=pjTimescaleMonths)
For k = 1 To TSV1.Count
If IsNumeric(TSV1(k)) Then
xlRange.Offset(i, p1).Value = Round(TSV1(k).Value, 0) & "%"
End If
p1 = p1 + 1
Next k
i = i + 1 'next assignment row
Next a
Else
'no assignments for this resource so increment to next row
i = i + 1
End If
Next r
'format completed worksheet
xl.Visible = True
WS1.Activate
WS1.UsedRange.Columns.AutoFit
WS1.Rows(2).Select
xl.ActiveWindow.FreezePanes = True
TotTim = Timer - TimSt
xl.Visible = False
MsgBox "Export is complete" & vbCr & _
" Export time: " & TotTim & " sec", vbInformation
xl.Visible = True
xl.GetSaveAsFilename InitialFileName:="Resource Tracking"
Set xl = Nothing
End Sub
'subroutine to pre-format worksheet
Sub ShFormat1()
WS1.Range("A1") = "Resource Name"
WS1.Range("B1") = "Assignment"
Set xlRange = WS1.Range("B1")
Dat = PrSt
'write weekly dates starting with cell B1 offset by i index
For i = 1 To TotMon
xlRange.Offset(0, i).Value = Format(Dat, "mmm-yy")
Dat = DateAdd("m", 1, Dat)
Next i
WS1.Rows(1).Font.Bold = True
End Sub
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
I am working on an Excel Userform to generate a report for a lot entered on a given day.
The report is stored in a Word document which contains the results of between 1 and 8 quality samples (number of samples varies by lot).
The Userform is meant to load in Excel, receive a lot number and date from the user, retrieve samples from that day and lot from a different sheet in the Excel workbook and then copy the data into a new Word doc based on a custom template.
The input part of the Userform and the Word template are both set up. I hit a snag on the event handling procedure for the "OK" button.
The form's OK button event handler gives
compile error
on
Sub makeReport(lNum As Integer, pDay As Date)
The editor isn't indicating an issue in my makeReport method; the call to makeReport in the event handler is highlighted red.
I am using the Excel 2013 VBA editor, and neither the built-in debugging tools in Excel, the Microsoft online VBA docs nor various forum posts found via Google can give me a complete answer to what is wrong and how to fix it.
OK Button event handler
Private Sub OKButton_Click() 'OK button
'Declare variables
Dim lNum As Integer
Dim pDay As Date
Dim name As String
Dim nStr As String
Dim dStr As String
'Error handler for incorrect input of lot number or pack date
On Error GoTo ErrorHandler
'Convert input values to correct types
nStr = TextBox1.Value
dStr = TextBox2.Value
'Set variable values
lNum = CInt(nStr)
MsgBox ("Step 1 Done" + vbCrLf + "Lot Number: " + nStr)
pDay = Format(dStr, "mm/dd/yyyy")
MsgBox ("Step 2 Done" + vbCrLf + "Pack Date: " + dStr)
name = nameDoc(pDay, lNum)
MsgBox ("Step 3 Done" + vbCrLf + "Report Name: " + name)
'Check for existing report
If Dir("\\CORE\Miscellaneous\Quality\Sample Reports\" + name) Then
MsgBox ("The file " + name + "already exists. Check \\CORE\Miscellaneous\Quality\Sample Reports for the report.")
Unload UserForm1
Exit Sub
Else
makeReport(lNum, pDay)
End If
'Unload User Form and clean up
Unload UserForm1
Exit Sub
ErrorHandler:
MsgBox ("Error. Please Try Again.")
'Unload UserForm1
End Sub
makeReport sub
Sub makeReport(lNum As Integer, pDay As Date)
'Template Path: \\CORE\Miscellaneous\Quality\Sample Reports\Template\Defect Report.dotm
'Save path for finished report: \\CORE\Miscellaneous\Quality\Sample Reports
'Generate doc name
Dim name As String
name = nameDoc(pDay, lNum)
'Initialize word objects and open word
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
Set wDoc = wApp.Documents.Add(Template:=("\\CORE\Miscellaneous\Quality\Sample Reports\Template\Defect Report.dotm"), NewTemplate:=False, DocumentType:=0)
'Initialize excel objects
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Defect Table")
'Fill in lot number and date at top of report
With wDoc
.Application.Selection.Find.Text = "<<date>>"
.Application.Selection.Find.Execute
.Application.Selection = pDay
.Application.Selection.EndOf
.Application.Selection.Find.Text = "<<lot>>"
.Application.Selection.Find.Execute
.Application.Selection = lNum
End With
'Initialize loop variables
Dim row1 As Integer
Dim row2 As Integer
Dim diff As Integer
Dim more As Boolean
Dim num As Integer, num1 As Integer, col As Integer
Dim count As Integer
count = 0
diff = 0
more = False
'Do while loop allows variable number of samples per day
Do While count < 8
'Checks for correct starting row of day
row1 = WorksheetFunction.Match(lNum, wsSheet.Range(), 0)
row2 = WorksheetFunction.Match(pDay, wsSheet.Range(), 0)
If IsError(row1) Or IsError(row2) Then
'Breaks for loop once all samples have been copied over
Exit Do
ElseIf row1 = row2 Then
num = 4
num1 = num
Do While num < 31
'Column variable
col = count + 1
'Copies data to word doc, accounting for blank rows in the word table
Select Case num
Case 6, 10, 16, 22, 30
num1 = num1 + 1
Case Else
num1 = num1
End Select
ActiveDocument.Tables(1).Cell(num1, col) = ActiveSheet.Range().Cells(row1, num)
num = num + 1
Next
Else
'Deiterates count to adjust for differences between row1 and row2
count = count - 1
End If
'Moves the collision to below row1 to allow MATCH to find next viable result
diff = row1 + 1
wsSheet = wsSheet.Range().Offset(diff, 0)
'Iterates count
count = count + 1
Loop
'Zeroes out word objects
Set wdDoc = Nothing
Set wdApp = Nothing
'Saves Document using regular name format for ease of access
wDoc.SaveAs2 Filename:="\\CORE\Miscellaneous\Quality\Sample Reports\" + name, FileFormat:=wdFormatDocumentDefault, AddtoRecentFiles:=False
End Sub
makeReport(lNum, pDay)
The brackets here imply that you are expecting something to be returned which can't happen as makeReport is a Sub not a Function. This is causing the compile error. To correct just remove the brackets.
You also have an additional problem as there is a mismatch with pDay. When you format a date you convert it from a Date, which is just a numeric value, into a String.
In OKButton_Click() try changing:
pDay = Format(dStr, "mm/dd/yyyy")
to:
pDay = CDate(dStr)
so that it matches the data type expected by makeReport. You can then apply the required formatting in makeReport by changing
.Application.Selection = pDay
to
.Application.Selection = Format(pDay, "mm/dd/yyyy")
Found a similar post on this question, but it was using an SQL Query and I'm using a DLookup.
I'm importing an Excel sheet to Access.
I'm getting the run-time 3075 - Syntax error (missing operator)... '[Component]='don't have/want a car'.
That particular Component already exists in the DB and it errors out at the comparison.
It's either the ' or the / that are causing the hang-up
Oh and I went with Variant on the tmpComponent b/c if I go String I get an Object required error at the Set tmpComponent = ... line. Maybe that is the problem, just not really sure.
Here is my Code and the bold is where the error occurs.
Thank you in advance for any direction you can provide.
Set rsCat = db.OpenRecordset("Categories", dbOpenDynaset, dbSeeChanges)
Dim x As Integer: x = 2
Dim LRow As Integer: LRow = ExLWb.Sheets("Categories").Cells(Rows.Count, 2).End(xlUp).Row
Dim tmpPFId As Variant, tmpCategory As Variant, tmpComponent As Variant, tmpSyntax As Variant, tmpCycle As Variant
Dim NewItem As Integer
NewItem = 0
'******************* LOOP THROUGH SPREADSHEET UPDATING CATEGORY TABLE
For x = 2 To LRow
Set tmpPFId = ExLWs.Cells(x, 2)
Set tmpCategory = ExLWs.Cells(x, 3)
Set tmpComponent = ExLWs.Cells(x, 4)
Set tmpSyntax = ExLWs.Cells(x, 5)
Set tmpCycle = ExLWs.Cells(x, 9)
**If IsNull(DLookup("[Component]", "[Categories]", "[Component]= '" & tmpComponent & "'")) Then**
rsCat.AddNew
rsCat!PF_ID = tmpPFId
rsCat!Category = tmpCategory
rsCat!component = tmpComponent
rsCat!Syntax = tmpSyntax
rsCat!Active = True
rsCat!Available = True
rsCat!Cycle = tmpCycle
rsCat.Update
NewItem = NewItem + 1
End If
Next x
Disregard, I figured out I should have gone with:
If IsNull(DLookup("[Category]", "[Categories]", "[Category]= """ & tmpCategory & """ & [Component]= """ & tmpComponent & """")) Then
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