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")
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
So I've got this Excel workbook that has some macro's. Users are presented with a button to either create a worksheet with the current date as name, or enter a date manually and that worksheet will be created.
Now the issue: The worksheet has two sheet ('Initial' and 'Version') that must be first and last. However, all worksheets created in between should be sorted on date everytime a new sheet is created. And I mean sorted on date, the sheets are 'DD-MM-YY' so e.g. I could have names like '1-11-21', '2-11-21', '11-11-21' and '21-11-21' in the same workbook and it should be sorted ascending.
Any suggestions? A normal sort just messes things up I found (1-11-21 and 11-11-21, followed by '2-11-21' and '21-11-21'....
Thanks,
Jasper
Sorting sheets of a workbook is rather easy, there a numerous examples out there, looking more or less like this:
Sub SortSheets(Optional wb As Workbook = Nothing)
If wb Is Nothing Then Set wb = ActiveWorkbook ' (or maybe ThisWorkbook)
Application.ScreenUpdating = False
Dim i As Long, j As Long
For i = 1 To wb.Worksheets.Count - 1
For j = i + 1 To wb.Worksheets.Count
' ==> The following line needs to be replaced!
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
wb.Worksheets(j).Move before:=wb.Worksheets(i)
End If
Next j
Next i
' Application.ScreenUpdating = True
End Sub
The only logic you need to change now is the If-statement. Instead of comparing the names of the sheets, you need to find a custom logic that compares the names of the two sheets.
Your logic is basically: If the name is Initial, sort it to the top, if it is Version, sort it to the end and for all the others, sort them by the date the name is representing.
I created a small function that calculates a number from the name. The Initial sheets gets 0, the Version gets a arbitrary high number, a worksheet with a date in the name gets the date value (a date is basically a double value in VBA) by converting the name into the date. If the name cannot be converted to a date, the value will be so that the sheet will be sorted to the end (but before the version sheet).
Function getSortNumber(ws As Worksheet) As Double
Const MaxNumber = 100000
If ws.Name = "Initial" Then
' Sort Initial to the beginning
getSortNumber = 0
ElseIf ws.Name = "Version" Then
' Sort Version to the end
getSortNumber = MaxNumber + ws.Parent.Sheets.Count
Else
' Create real date fom name
Dim d As Date, tokens() As String
tokens = Split(ws.Name, "-")
On Error Resume Next
d = DateSerial(Val(tokens(2)), Val(tokens(1)), Val(tokens(0)))
On Error GoTo 0
If d = 0 Then
' Failed to convert to date, sort to end
getSortNumber = MaxNumber + ws.Index
Else
' Sort according to the date value
getSortNumber = CDbl(d)
End If
End If
End Function
You can adapt the function easily if your needs changed (eg date format, or you can have extra text with the date, or you want to sort the version sheet to the beginning, or you have additional sheets with different names...). The sort function itself will not change at all, only the comparison logic.
Now all you have to do is change the line in the sort routine:
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
to
If getSortNumber(wb.Worksheets(j)) < getSortNumber(wb.Worksheets(i)) Then
The general approach of converting the sheet names (that, hopefully, look like dates) to actual date serial numbers, and sorting those has been answered. But there is a a bit more to it than other answers show.
If your sheet names are user entered, you should handle a bit of variability
No need to reinvent Date Conversion, use whats already in Excel/VBA. But you need to define what year a 2 digit number represents, specifically which century it's in.
Note: How DateSerial interprets 2 digit dates is a bit complex. Refer to the docs for details
Decide what you want to do with sheets whose names cannot be converted to valid dates. Options include
Clean them up. eg
remove excess white space
allow for suffixes (times?)
alternate delimiters
other date forms (eg 1 Oct 2020)
etc
Aborting
Delete them
Move them to a defined location
Move them to another workbook
Prompt user for a new valid name
Generate a new valid name in the code
etc
Once the date serial numbers are created, you sort that data. Many options exist
Use the Dynamic Array function SORT, if you have it
If you don't, there are many Array Sort algorithms and implementations available for VBA
Examples 1 2
Use a data structure that supports Sorting. Example System.Collections.ArrayList 1
Dump the data onto a sheet and use Excel Sort
Once you have the sorted data, move the sheets into place. Note: another answer provide a nested For loop. This executes in order n^2 (n = number of sheets) May not matter for a smallish number of sheets, but will get much slower as the number of sheets increases. But it's easily avoided, see the code below.
Suggested methodoligy, including comments on what to change to suit your needs. Run this after the user has inserted a new sheet.
Sub SortSheets()
Dim ws As Worksheet
Dim wb As Workbook
Dim idx As Long
Dim SheetNames As Variant
Set wb = ThisWorkbook ' or specify the book you want
' Validate book contents
On Error Resume Next
Set ws = wb.Worksheets("Initial")
On Error GoTo 0
If ws Is Nothing Then
' Initial Doesn't exist. What now?
Exit Sub
End If
If ws.Index <> 1 Then
' Move it to first
ws.Move Before:=wb.Worksheets(1)
End If
On Error Resume Next
Set ws = wb.Worksheets("Version")
On Error GoTo 0
If ws Is Nothing Then
' Version Doesn't exist. What now?
Exit Sub
End If
If ws.Index <> wb.Worksheets.Count Then
' Move it to last
ws.Move After:=wb.Worksheets(wb.Worksheets.Count)
End If
' For each sheet between first and last,
' Convert Name to a dateSerial
' Handle any invalidly named sheets
ReDim SheetNames(2 To wb.Worksheets.Count - 1, 1 To 2)
For idx = 2 To wb.Worksheets.Count - 1
Set ws = wb.Worksheets(idx)
On Error Resume Next
' convert sheet name to date
SheetNames(idx, 1) = getDate(ws.Name)
On Error GoTo 0
If IsEmpty(SheetNames(idx, 1)) Then
' Invalid Sheet Name format. What Now?
' eg move it to the end (before Version)
SheetNames(idx, 1) = 3000000
' change to handle as you require, eg Delete it, Prompt user for a new name, etc
End If
SheetNames(idx, 2) = ws.Name
Next
' Sort on date using Dynamic Array Function SORT
SheetNames = Application.Sort(SheetNames)
' If SORT is not available, there are many Array Sort algorithms and implementations available
' Move sheets into position
' SheetNames is a 2D array of the DateSerial numbers and actual sheet names, sorted in the order we want them in the book
' Loop through the array lowest to highest,
' Get a reference to the sheet by name
' Move it to its required position (if it's not already there)
For idx = 1 To UBound(SheetNames, 1)
Set ws = wb.Worksheets(SheetNames(idx, 2))
If ws.Index <> idx + 1 Then
ws.Move After:=wb.Worksheets(idx)
End If
Next
End Sub
Function getDate(DateStr As String, Optional Delim As String = "-") As Long
' Cleanup sheet name
' Add or remove cleaning to suit your needs
' reduce multiple space sequences to single spaces
DateStr = Application.WorksheetFunction.Trim(DateStr)
' remove spaces aroung delimiter
DateStr = Replace$(DateStr, " " & Delim, Delim) '
DateStr = Replace$(DateStr, Delim & " ", Delim)
' replace any remaining spaces with delimiter (needed to make Val() work as desired)
DateStr = Replace$(DateStr, " ", Delim)
' Create real date from name
Dim d As Long, Segments() As String
Segments = Split(DateStr, Delim)
If UBound(Segments) < 2 Then
' not enough segments
d = 0
ElseIf UBound(Segments) > 2 Then
' too many segments. What Now?
' do nothing if it's acceptable to ignore anything after the date
Else
' Segment(0) is first part, assumed to be Day
' Segment(1) is second part, assumed to be Month
' Segment(2) is third part, assumed to be Year
' assume 2 digit dates are 2000's. Change to suit your needs
' Note: relying on DateSerial to convert 2 digit dates may give unexpected results
' as what you get depends on Excel version and local settings
If Len(Segments(2)) <= 2 Then Segments(2) = "20" & Format$(Segments(2), "00")
On Error Resume Next
d = CLng(DateSerial(CInt(Val(Segments(2))), CInt(Segments(1)), CInt(Segments(0))))
On Error GoTo 0
End If
If d = 0 Then
' Could not convert to date. Let calling routine decide what to do now
Err.Raise 1, "getDate", "Invalid Date string"
Else
' return date value
getDate = d
End If
End Function
Insert Date Worksheet
Note the following in two-digit year notation:
01/01/30 ... 01/01/1930
12/31/99 ... 12/31/1999
01/01/00 ... 01/01/2000
12/31/29 ... 12/31/2029
Some complications are present due to:
Sub Test1()
Debug.Print DateSerial(111, 22, 33) ' Result '11/02/112'
Debug.Print DateSerial(21, 2, 30) ' Result ' 03/02/2021
End Sub
The following will not sort any previously added worksheets. It will just insert the new worksheet in the right spot i.e. before the first worksheet with a greater date than the date supplied, or before the last worksheet (if no greater date).
Option Explicit
Sub InsertDateWorksheet()
' Needs 'RefWorksheet', 'InputDateText', 'GetTwoDigitYearDate' and 'IsLeapYear'.
Const ProcName As String = "InsertDateWorksheet"
Const First As String = "Initial"
Const Last As String = "Version"
Const Delimiter As String = "-"
Dim wb As Workbook: Set wb = ThisWorkbook
' First Worksheet
Dim fws As Worksheet: Set fws = RefWorksheet(wb, First, True)
If fws Is Nothing Then Exit Sub
If Not fws Is wb.Sheets(1) Then
fws.Move Before:=wb.Sheets(1)
End If
' Last Worksheet
Dim lws As Worksheet: Set lws = RefWorksheet(wb, Last, True)
If lws Is Nothing Then Exit Sub
Dim shCount As Long: shCount = wb.Sheets.Count
If Not lws Is wb.Sheets(shCount) Then
lws.Move After:=wb.Sheets(shCount)
End If
Dim NewDate As Date: NewDate = InputDateText(True)
If NewDate = 0 Then Exit Sub
Dim NewDateString As String: NewDateString = CStr(Day(NewDate)) _
& Delimiter & CStr(Month(NewDate)) & Delimiter _
& Right(CStr(Year(NewDate)), 2)
Dim nws As Worksheet: Set nws = RefWorksheet(wb, NewDateString)
If Not nws Is Nothing Then
MsgBox "The worksheet '" & NewDateString & "' already exists.", _
vbCritical, ProcName
Exit Sub
End If
Dim ws As Worksheet
Dim wsDate As Date
For Each ws In wb.Worksheets
Select Case ws.Name
Case First
Case Last
Exit For
Case Else
wsDate = GetTwoDigitYearDate(ws.Name, Delimiter)
If NewDate < wsDate Then
Exit For
End If
End Select
Next ws
Worksheets.Add(Before:=ws).Name = NewDateString
MsgBox "Worksheet '" & NewDateString & "' added.", vbInformation, ProcName
End Sub
Function RefWorksheet( _
ByVal wb As Workbook, _
ByVal WorksheetName As String, _
Optional ByVal DoWriteMessage As Boolean = False) _
As Worksheet
Const ProcName As String = "RefWorksheet"
On Error Resume Next
Set RefWorksheet = wb.Worksheets(WorksheetName)
On Error GoTo 0
If DoWriteMessage Then
If RefWorksheet Is Nothing Then
MsgBox "Worksheet '" & WorksheetName & "' not found.", _
vbCritical, ProcName
Exit Function
End If
End If
End Function
Function InputDateText( _
Optional ByVal DoWriteMessage As Boolean = False) _
As Date
' Needs 'GetTwoDigitYearDate' and 'IsLeapYear'.
Const ProcName As String = "InputDateText"
Const InputFormat As String = "d-m-yy"
Const nTitle As String = "Input Date Text"
Dim nPrompt As String
nPrompt = "Please enter a date in '" & InputFormat & "' format..."
Dim nDefault As String: nDefault = Format(Date, InputFormat)
Dim NewDateString As Variant: NewDateString = Application.InputBox( _
nPrompt, nTitle, nDefault, , , , , 2)
If NewDateString = False Then
MsgBox "You canceled.", vbExclamation, ProcName
Exit Function
End If
InputDateText = GetTwoDigitYearDate(NewDateString, "-")
If DoWriteMessage Then
If InputDateText = 0 Then
MsgBox "The string '" & NewDateString & "' is not valid.", _
vbCritical, ProcName
End If
End If
End Function
Function GetTwoDigitYearDate( _
ByVal DateString As String, _
Optional ByVal Delimiter As String = "-") _
As Date
' Needs 'IsLeapYear'.
On Error GoTo ClearError
Dim ArrDate() As String: ArrDate = Split(DateString, Delimiter)
Dim nYear As Long: nYear = CLng(ArrDate(2))
Select Case nYear
Case Is < 0, Is > 99
Exit Function
Case Else
nYear = IIf(nYear > 29, nYear + 1900, nYear + 2000)
End Select
Dim nMonth As Long: nMonth = CLng(ArrDate(1))
Select Case nMonth
Case Is < 1, Is > 12
Exit Function
End Select
Dim nDay As Long: nDay = CLng(ArrDate(0))
Select Case nDay
Case Is < 1, Is > 31
Exit Function
End Select
Select Case nMonth
Case 4, 6, 9, 11
If nDay = 31 Then Exit Function
Case 2
If nDay > 29 Then Exit Function
If nDay = 29 Then
If Not IsLeapYear(nYear) Then Exit Function
End If
End Select
GetTwoDigitYearDate = DateSerial(nYear, nMonth, nDay)
ProcExit:
Exit Function
ClearError:
Resume ProcExit
End Function
Function IsLeapYear( _
TestYear As Long) _
As Boolean
If TestYear Mod 4 = 0 Then
If TestYear Mod 100 = 0 Then
If TestYear Mod 400 = 0 Then
' Accounting for e.g. years 2000, 2400, 2800...8800, 9200, 9600.
IsLeapYear = True
'Else
' Accounting for e.g. years 2100, 2200, 2300...9700, 9800, 9900.
'isLeapYear = False
End If
Else
' Accounting for e.g. years 1904, 1908, 1912...1988, 1992, 1996.
IsLeapYear = True
End If
'Else
' Accounting for e.g. years 1901, 1902, 1903...1997, 1998, 1999.
'isLeapYear = False
End If
End Function
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 trying to obtain the numbered locations of my bookmarks (paragraph number without context) in a Word document (a lengthy legal document template) and. I am currently using the following code to pull the bookmarked text values from the Word document into an Excel workbook I've built out to grab other data from other sources, but I haven't been able to figure out how to manipulate the code to grab the bookmark's paragraph numbers (I searched high and low for this one too, and am a VBA newbie. I know just enough to be dangerous, but not enough to be helpful lol). Please Help!
Sub SectionLocationImportTESTING()
Dim intDocCount As Integer
Dim wdApp As Word.Application, wdDoc As Word.Document, xlWb As Excel.Workbook, xlWs As Excel.Worksheet
Dim BookmarkText As String
Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0
If wdApp Is Nothing Then
MsgBox "There are no MS Word Documents open.", vbInformation, "No Word Documents open"
Exit Sub
End If
Set xlWb = ThisWorkbook
Set xlWs = ActiveWorkbook.Sheets("Data Input")
intDocCount = wdApp.Documents.Count
If intDocCount > 1 Then
MsgBox "There are " & intDocCount & " Word Documents open." & vbNewLine & vbNewLine & _
"Please close the additional MS Word Documents", vbCritical, "Too many Word Documents open!"
Set wdApp = Nothing
Exit Sub
End If
With wdApp
Set wdDoc = wdApp.ActiveDocument
wdDoc.Activate
'This is very abbreviated, I have about 300 bookmarks that transfer
If wdDoc.Bookmarks.Exists("Section_Rent") = True Then
BookmarkText = wdDoc.Bookmarks("Section_Rent").Range.Text
xlWs.Cells(202, 22) = ("Section_Rent")
xlWs.Cells(202, 23) = BookmarkText
End If
End With
ActiveWorkbook.RefreshAll
ActiveSheet.PivotTables("Data_Input_Table").PivotFields("Trimmed Data"). _
PivotFilters.Add2 Type:=xlCaptionIsGreaterThan, Value1:="0"
Columns("D:D").EntireColumn.AutoFit
Range("A1").Select
MsgBox "Transfer is complete."
End Sub
I don't think there's a straight-forward way of doing that.
You could do this for example:
Sub Tester()
Debug.Print ParagraphNumber(Selection.Range)
End Sub
Function ParagraphNumber(rng As Range)
ParagraphNumber = rng.Document.Range(0, rng.End).Paragraphs.Count
End Function
...but it will also count "empty" paragraphs.
If you have a lot of bookmarks, you could consider listing the names in your Excel sheet and then looping over that range to run the text extraction. If you hard-code all those names into your VBA that's going to be very hard to maintain.
E.g.
'...
Dim c As Range, bm As String, rngBM As Word.Range
'...
'...
Set wdDoc = wdApp.ActiveDocument
wdDoc.Activate
'range with your bookmark names
Set rngBM = ThisWorkbook.Sheets("Bookmarks").Range("A2:A300")
For Each c In rngBM.Cells
bm = c.Value 'bookmark name
If wdDoc.Bookmarks.Exists(bm) Then
Set rngBM = wdDoc.Bookmarks(bm).Range
'for demo purposes just putting info next to the bookmark name...
c.Offset(0, 1).Value = rngBM.Text
c.Offset(0, 2).Value = ParagraphNumber(rngBM)
End If
Next c
There's 2 ways to get the paragraph number, depending on what you want:
Option 1
This will get the exact string of the auto-numbering that you see in the paragraph itself:
E.g. the below paragraph will get you 1.
This is a test paragraph.
If wdDoc.Bookmarks.Exists("Section_Rent") Then
Dim BookmarkText As String
BookmarkText = wdDoc.Bookmarks("Section_Rent").Range.Text
xlWs.Cells(202, 22) = "Section_Rent"
xlWs.Cells(202, 23) = BookmarkText
Dim BookmarkParaNum As String
BookmarkParaNum = wdDoc.Bookmarks("Section_Rent").Range.ListFormat.ListString
xlWs.Cells(202, 24) = BookmarkParaNum
End If
Option 2
This will get the string that you see if you insert a cross reference to the paragraph:
Using the below code for the same paragraph in Option 1 will give you just 1, the same as what inserting it as cross reference will get you.
wdDoc.Paragraphs.Last.Range.InsertParagraphAfter 'A temporary paragraph for inserting field later
Dim fieldRng As Range
Set fieldRng = wdDoc.Paragraphs.Last.Range.Duplicate
If wdDoc.Bookmarks.Exists("Section_Rent") Then
Dim BookmarkText As String
BookmarkText = wdDoc.Bookmarks("Section_Rent").Range.Text
xlWs.Cells(202, 22) = "Section_Rent"
xlWs.Cells(202, 23) = BookmarkText
fieldRng.InsertCrossReference ReferenceType:="Bookmark", ReferenceKind:=wdNumberNoContext, ReferenceItem:="Section_Term", InsertAsHyperlink:=True, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
Dim tempField As Field
Set tempField = fieldRng.Fields(1)
Dim BookmarkParaNum As String
BookmarkParaNum = tempField.Result
xlWs.Cells(202, 24) = BookmarkParaNum
tempField.Delete
End If
fieldRng.Delete 'Delete the temporary paragraph
I have a loop that can go on for ages, although the "Enheder" worksheet only has like 10 rows, and the dataset im loadin has maybe 300 rows, it's taking a REALLY long time when I try to import.
Public Function ImportData()
Dim resultWorkbook As Workbook
Dim curWorkbook As Workbook
Dim importsheet As Worksheet
Dim debugsheet As Worksheet
Dim spgsheet As Worksheet
Dim totalposts As Integer
Dim year As String
Dim month As String
Dim week As String
Dim Hospital As String
Dim varType As String
Dim numrows As Integer
Dim Rng As Range
Dim colavg As String
Dim timer As String
Dim varKey As String
year = ImportWindow.ddYear.value
month = ImportWindow.ddMonth.value
week = "1"
varType = ImportWindow.ddType.value
Hospital = ImportWindow.txtHospital.value
Set debugsheet = ActiveWorkbook.Sheets("Data")
Set spgsheet = ActiveWorkbook.Sheets("Spørgsmål")
Set depsheet = ActiveWorkbook.Sheets("Enheder")
Set resultWorkbook = OpenWorkbook()
setResultColVars debugsheet
'set sheets
Set importsheet = resultWorkbook.Sheets("Dataset")
numrows = debugsheet.UsedRange.Rows.Count
'make sure that the enhed can be found in the importsheet, so the units can be extracted accordingly
If Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
Dim DepColumn
Dim aCell
DepColumn = importsheet.UsedRange.Find("afdeling").column
'sort importsheet to allow meaningfull row calculations
Set aCell = importsheet.UsedRange.Columns(DepColumn)
importsheet.UsedRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
Dim tempRange As Range
Dim SecColumn
Dim secRange As Range
'find row ranges for departments
Application.ScreenUpdating = False
'**Here's the loop that will go on for aaaaaages until I decide to ctrl+pause**
For Each c In depsheet.UsedRange.Columns(1).Cells
splStr = Split(c.value, "_")
If UBound(splStr) = -1 Then
ElseIf UBound(splStr) = 0 Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, DepColumn, splStr(0)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), 0, varType, False)
ElseIf UBound(splStr) = 1 And Not (importsheet.UsedRange.Find("afdeling_" & splStr(0)) Is Nothing) Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, importsheet.UsedRange.Find("afdeling_" & splStr(0)).column, splStr(1)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), splStr(1), varType, False)
End If
Next
Application.ScreenUpdating = True
' go through columns to get total scores
totalposts = totalposts + IterateColumns(importsheet.UsedRange, spgsheet, importsheet, debugsheet, year, month, week, Hospital, 0, 0, varType, True)
resultWorkbook.Close Saved = True
ResultsWindow.lblPoster.Caption = totalposts
ImportWindow.Hide
ResultsWindow.Show
Else
MsgBox "Kunne ikke finde afdelingskolonnen. Kontroller at der er er en kolonne med navnet 'afdeling' i dit datasæt"
End If
End Function
Function GetRowRange(sheetRange, column, value) As Range
'check for a valid section column
sheetRange.AutoFilterMode = False
sheetRange.UsedRange.AutoFilter Field:=column, Criteria1:=value
Set GetRowRange = sheetRange.UsedRange.SpecialCells(xlCellTypeVisible)
sheetRange.AutoFilterMode = False
End Function
'iterates through columns of a range to get the averages based on the column headers
Function IterateColumns(varRange As Range, spgsheet, importsheet, resultsheet, year, month, week, Hospital, dep, sec, varType, sortspg As Boolean)
Dim numrows
Dim totalposts
Dim usedRng
totalposts = 0
numrows = resultsheet.UsedRange.Rows.Count
Dim insert
insert = True
If Not (varRange Is Nothing) Then
' go through columns to get scores
For i = 1 To varRange.Columns.Count
Dim tempi
tempi = numrows + totalposts + 1
Set Rng = varRange.Columns(i)
With Application.WorksheetFunction
'make sure that the values can calculate
If (.CountIf(Rng, "<3") > 0) Then
colavg = .SumIf(Rng, "<3") / .CountIf(Rng, "<3")
insert = True
Else
insert = False
End If
End With
'key is the variable
varKey = importsheet.Cells(1, i)
'only add datarow if the data matches a spg, and the datarow is not actually a department
If (sortSpgs(varKey, spgsheet, sortspg)) And (insert) And Not (InStr(key, "afdeling")) Then
resultsheet.Cells(tempi, WyearCol).value = year
resultsheet.Cells(tempi, WmonthCol).value = month
resultsheet.Cells(tempi, WweekCol).value = "1"
resultsheet.Cells(tempi, WhospCol).value = "Newport Hospital"
resultsheet.Cells(tempi, WdepCol).value = "=VLOOKUP(N" & tempi & ",Enheder!$A:$B,2,0)"
resultsheet.Cells(tempi, WsecCol).value = "=IFERROR(VLOOKUP(O" & tempi & ",Enheder!$A:$B,2,0),"" "")"
resultsheet.Cells(tempi, WdepnrCol).value = dep
resultsheet.Cells(tempi, WsecnrCol).value = dep & "_" & sec
resultsheet.Cells(tempi, WjtypeCol).value = varType
resultsheet.Cells(tempi, WspgCol).value = varKey
resultsheet.Cells(tempi, WsporgCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,6,0)"
resultsheet.Cells(tempi, WtestCol).value = ""
resultsheet.Cells(tempi, Wsv1Col).value = colavg
resultsheet.Cells(tempi, Wsv2Col).value = (1 - colavg)
resultsheet.Cells(tempi, Wsv3Col).value = ""
resultsheet.Cells(tempi, WgrpCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,4,0)"
totalposts = totalposts + 1
End If
Next
End If
IterateColumns = totalposts
End Function
'Function that gets the workbook for import
Function OpenWorkbook()
Dim pathString As String
Dim resultWorkbook As Workbook
pathString = Application.GetOpenFilename(fileFilter:="All Files (*.*), *.*")
' check if it's already opened
For Each wb In Workbooks
If InStr(pathString, wb.Name) > 0 Then
Set resultWorkbook = wb
Exit For
End If
Next wb
If Not found Then
Set resultWorkbook = Workbooks.Open(pathString)
End If
Set OpenWorkbook = resultWorkbook
End Function
'find column numbers for resultsheet instead of having to do this in every insert
Function setResultColVars(rsheet)
WyearCol = rsheet.UsedRange.Find("År").column
WmonthCol = rsheet.UsedRange.Find("Måned").column
WweekCol = rsheet.UsedRange.Find("Uge").column
WhospCol = rsheet.UsedRange.Find("Hospital").column
WdepCol = rsheet.UsedRange.Find("Afdeling").column
WsecCol = rsheet.UsedRange.Find("Afsnit").column
WdepnrCol = rsheet.UsedRange.Find("Afdelingsnr").column
WsecnrCol = rsheet.UsedRange.Find("Afsnitnr").column
WjtypeCol = rsheet.UsedRange.Find("Journaltype").column
WspgCol = rsheet.UsedRange.Find("spg").column
WsporgCol = rsheet.UsedRange.Find("spørgsmål").column
WtestCol = rsheet.UsedRange.Find("test").column
Wsv1Col = rsheet.UsedRange.Find("Svar 1").column
Wsv2Col = rsheet.UsedRange.Find("Svar 0").column
Wsv3Col = rsheet.UsedRange.Find("Svar 3").column
WgrpCol = rsheet.UsedRange.Find("Gruppering").column
End Function
Function sortSpgs(key, sheet, sortspg As Boolean)
If Not (sheet.UsedRange.Find(key) Is Nothing) Then
If (sortspg) Then
ResultsWindow.lstGenkendt.AddItem key
End If
sortSpgs = True
Else
If (sortspg) Then
ResultsWindow.lstUgenkendt.AddItem key
End If
sortSpgs = False
End If
End Function
Function Progress()
iProgress = iProgress + 1
Application.StatusBar = iProgress & "% Completed"
End Function
Difficult to debug without the source files.
I see the following potential problems:
GetRowRange: .UsedRange might return more columns than you expect. Check by pressing Ctrl-End in the worksheet and see where you end up
Some thing in your main routine - depsheet.UsedRange.Columns(1).Cells might just result in much more rows than expected
someRange.Value = "VLOOKUP(... will store the formula as text. You need .Formula = instead of .Value (this will not solve your long runtime but certainly avoid another bug)
In sortSpgs you add know or unknow items to a control. Not knowing if there's any event code behind these controls, disable events with Application.EnableEvents=False (ideally in the beginning of your main sub together with the .ScreenUpdating = False)
Also, set Application.Calculation = xlCalculationManual at the beginning and Application.Calculation = xlCalculationAutomatic at the end of your code
You're performing a lot of .Find - esp. in sortSpgs - this is potentially slow in large sheets, as it has to loop over quite some data, depending on the underlying range.
Generally, a few more "best practise remarks":
* Dim your variables with the correct types, same for returns of functions
* Use With obj to make the code cleaner. E.g. in setResulcolVars you could use With rsheet.UsedRange and remove this part in the following 15 or so lines
* In modules of small scope, it is okay to dim some variable with a module wide scope - esp. if you hand them over with every call. This will make your code much easier to read
Hope that helps a bit... mvh /P.
My guess is that Application.Screenupdating is the problem. You set to false inside the:
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
block. So if the isn't the case then screenupdateing isn't disabled. you should move it to the beginning of the function.
you could also try to write the usedrange in an array, work with it , and write it back if needed.
code example
dim MyArr() as Variant
redim MyArray (1 to usedrange.rows.count, 1 to usedrange.columns)
MyArray=usedrange.value
'calculating with Myarray instead of ranges (faster)
usedrange.value=myarray 'writes changes back to the sheet/range
also, maybe you can use .match instead of .find, wich is faster.
with arrays you use application.match( SearchValue, Array_Name, False) 'false if for exact match
the same thing works for range.find() , becoming application.find()...
save first your master workbook under a new name before making such a big change...