Re: Prevent Worksheet Protection
Thanks, that does what I want.
Re: Prevent Worksheet Protection
Thanks, that does what I want.
I have a workbook for which I would like to protect the worksheets, while still allowing my code to alter the worksheets, which can be done with the line:
However, I want allow some users (who know the password) to be able to unprotect the sheet if they need to edit it, then turn the protection back on after they are done. How can I make sure that they use my macro to protect the sheet with UserInterfaceOnly set to true, rather than the standard way to turn on protection?
That is, is there a way I can prevent the user from being able to protect the sheet with the Tools->Protection->Protect Sheet menu item?
Thanks
Re: Findnext Stops Working In Nested Loops
Perhaps if you post a sample workbook showing what the data looks like before running your code and what it should look like after, if the code was working?
Re: Undo Macro
Does this work for you?
Option Explicit
Public Const SZ_WS_APPROVED As String = "Approved"
Public Const SZ_WS_DELETE As String = "Del 2006"
Public Const SZ_WS_ADD As String = "Add 2006"
Public Const SZ_WS_CHG As String = "Chg 2006"
Public Const SZ_WS_UNDO As String = "Undo"
Public Const ROW_FIRSTUNDO As Long = 2
Public Const ROW_FIRST As Long = 5
Public Const COL_B As Integer = 2
Public Const COL_F As Integer = 6
Public Const COL_H As Integer = 8
Public Const COL_J As Integer = 10
Public Const COL_R As Integer = 18
Public Const COL_V As Integer = 22
Public Const COL_X As Integer = 24
Public Const COL_WB As Integer = 1
Public Const COL_WS As Integer = 2
Public Const COL_ROW As Integer = 3
Public Const COL_FIRSTUNDO As Integer = 4
Public Const CODE_DELETE As Integer = 2
Public Const CODE_ADD As Integer = 1
Public Const CODE_CHANGE As Integer = 3
Public Sub CheckX(lSourceRow As Long)
Dim szMessage As String
Dim szTargetSheet As String
Dim lTargetRow As Long
Dim iLastColumn As Integer
With Sheets(SZ_WS_APPROVED).Cells(lSourceRow, COL_X)
If IsNumeric(.Value) Then
Select Case .Value
' Deleting a value
Case CODE_DELETE
szMessage = "Are you sure you want to delete?"
szTargetSheet = SZ_WS_DELETE
iLastColumn = COL_V
' Adding a Credit
Case CODE_ADD
szMessage = "Is this a new addition?"
szTargetSheet = SZ_WS_ADD
iLastColumn = COL_V
Case CODE_CHANGE
szMessage = "Is this a rating change?"
szTargetSheet = SZ_WS_CHG
iLastColumn = COL_R
' If an invalid code is given
Case Else
' Do nothing, exit the procedure
Exit Sub
End Select
' Ask the user if the procedure should really be run
If (vbYes = MsgBox(szMessage, vbYesNo, "ExcelTips")) Then
' Disable alerts & screen updating
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
' Find the last row of data in the target sheet
lTargetRow = FindLastRow(szTargetSheet, COL_B) + 1
' Copy first part of data
Call CopyData(szTargetSheet, lSourceRow, lTargetRow, COL_B, COL_F)
' Copy second part of data
Call CopyData(szTargetSheet, lSourceRow, lTargetRow, COL_J, iLastColumn)
' Add the date that this procedure was run
Call AddDate(szTargetSheet, lTargetRow)
Select Case .Value()
Case CODE_DELETE
' Delete the row
Call DeleteRow(SZ_WS_APPROVED, lSourceRow, iLastColumn)
Case CODE_CHANGE
' Ask the user to enter the ratings
Call MsgBox("You must enter the current and previous ratings manually.")
Sheets(szTargetSheet).Select
End Select
' Delete the procedure type value
.Clear
' Enable alerts & screen updating
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End If
End If
End With
End Sub
Private Function FindLastRow(szSheetName As String, iColumn As Integer) As Long
Dim rgLastCell As Range
With Worksheets(szSheetName)
' Set a reference to the cell in the last row of the given column & sheet
Set rgLastCell = .Cells(.Rows.Count, iColumn)
End With
' If this cell is empty
If (IsEmpty(rgLastCell)) Then
' Change the reference to the last non-empty cell in the given column & sheet
Set rgLastCell = rgLastCell.End(xlUp)
End If
' Return the row of the referenced cell
FindLastRow = rgLastCell.Row
End Function
Private Function FindLastColumn(szSheetName As String, lRow As Long) As Integer
Dim rgLastCell As Range
With Worksheets(szSheetName)
' Set a reference to the cell in the last column of the given row & sheet
Set rgLastCell = .Cells(lRow, .Columns.Count)
End With
' If this cell is empty
If (IsEmpty(rgLastCell)) Then
' Change the reference to the last non-empty cell in the given row & sheet
Set rgLastCell = rgLastCell.End(xlToLeft)
End If
' Return the column of the referenced cell
FindLastColumn = rgLastCell.Column
End Function
Private Sub CopyData(szTargetSheet As String, lSourceRow As Long, lTargetRow As Long, iFirstCol As Integer, iLastCol As Integer, Optional szSourceSheet As String = SZ_WS_APPROVED)
' Copy the data from the source sheet
With Sheets(szSourceSheet)
.Range(.Cells(lSourceRow, iFirstCol), .Cells(lSourceRow, iLastCol)).Copy
End With
' If the undo sheet is the target
If (SZ_WS_UNDO = szTargetSheet) Then
iFirstCol = COL_FIRSTUNDO + iFirstCol - 1
End If
' If the undo sheet is the source
If (SZ_WS_UNDO = szSourceSheet) Then
iFirstCol = iFirstCol - COL_FIRSTUNDO + 1
End If
' Paste the data to the appropriate output sheet
With Sheets(szTargetSheet)
Call .Paste(Destination:=.Cells(lTargetRow, iFirstCol))
End With
End Sub
Private Sub FormatCells(szTargetSheet As String, lTargetRow As Long)
' Copy the format for the new cells from the previous cells
With Sheets(szTargetSheet)
.Range(.Cells(lTargetRow - 1, COL_B), .Cells(lTargetRow - 1, COL_V)).Copy
Call .Range(.Cells(lTargetRow, COL_B), .Cells(lTargetRow, COL_V)).PasteSpecial(Paste:=xlPasteFormats)
End With
End Sub
Private Sub AddDate(szTargetSheet As String, lTargetRow As Long)
' Add the date to the appropriate row
With Sheets(szTargetSheet).Cells(lTargetRow, COL_H)
.Value = Format(DateTime.Date(), "mm/dd/yyyy")
End With
End Sub
Private Sub DeleteRow(szSourceSheet As String, lRowToDelete As Long, iLastColumn As Integer)
If (vbYes = MsgBox("Do you want to delete this row?", vbYesNo, "ExcelTips")) Then
' Write the undo data
Call WriteUndoData(szSourceSheet, lRowToDelete, iLastColumn)
' Delete the row
Worksheets(szSourceSheet).Rows(lRowToDelete).Delete
' If this was a mistake
If (vbNo = MsgBox("Is this what you wanted to do?", vbYesNo, "ExcelTips")) Then
' Undo the row deletion
Call UndoDelete(lRowToDelete)
End If
End If
End Sub
Private Sub WriteUndoData(szSourceSheet As String, lRowToDelete As Long, iLastColumn As Integer)
Dim lUndoRow As Long
Dim iColumn As Integer
' Find the next empty undo row
lUndoRow = FindLastRow(szSourceSheet, COL_WB) + 1
With Worksheets(SZ_WS_UNDO)
' If all undo rows have been filled
If (.Rows.Count < lUndoRow) Then
' Delete the first undo row
.Rows(ROW_FIRSTUNDO).Delete
' Use the last undo row
lUndoRow = .Rows.Count
End If
' Save the current values for undoing
.Cells(lUndoRow, COL_WB).Value = Worksheets(szSourceSheet).Parent.Name
.Cells(lUndoRow, COL_WS).Value = szSourceSheet
.Cells(lUndoRow, COL_WB).Value = lRowToDelete
' Copy first part of data
Call CopyData(SZ_WS_UNDO, lRowToDelete, lUndoRow, COL_B, COL_F)
' Copy second part of data
Call CopyData(SZ_WS_UNDO, lRowToDelete, lUndoRow, COL_J, iLastColumn)
End With
Call Application.OnUndo("Undo the DeleteRow macro", "UndoDelete")
End Sub
Public Sub UndoDelete(Optional lCurrentRow As Long = 0)
Dim szTargetWB As String, szTargetWS As String
Dim lUndoRow As Long, lTargetRow As Long
Dim iLastColumn As Integer
Dim bRowInserted As Boolean
' Find the last undo row
lUndoRow = FindLastRow(SZ_WS_UNDO, COL_WB)
' If undo data exists
If (ROW_FIRSTUNDO <= lUndoRow) Then
' Find the last undo column
iLastColumn = FindLastColumn(SZ_WS_UNDO, lUndoRow)
With Worksheets(SZ_WS_UNDO)
' Get the name of the target workbook
szTargetWB = .Cells(lUndoRow, COL_WB)
' Get the name of the target worksheet
szTargetWS = .Cells(lUndoRow, COL_WS)
' Get the target row
lTargetRow = .Cells(lUndoRow, COL_ROW)
' If a current row is not given or the current row is the last target row
If (0 = lCurrentRow Or lTargetRow = lCurrentRow) Then
' Turn off screen updating
Application.ScreenUpdating = False
' Attempt to re-insert the deleted target row
On Error Resume Next
Workbooks(szTargetWB).Worksheets(szTargetWS).Rows(lTargetRow).Insert
bRowInserted = (0 = Err)
On Error GoTo 0
' If the target row was re-inserted successfully
If (bRowInserted) Then
' Copy the data
Call CopyData(szTargetWS, lUndoRow, lTargetRow, COL_FIRSTUNDO, iLastColumn, SZ_WS_UNDO)
' Delete the undo data
Call .Rows(lUndoRow).Delete
' If the target row was not re-inserted
Else
' Inform the user that the procedure cannot be undone
Call MsgBox("This action cannot be undone.")
End If
' Turn on screen updating
Application.ScreenUpdating = True
End If
End With
End If
End Sub
Display More
Note: you MUST ensure that your workbook includes a worksheet called "Undo".
Re: Enabling Macros Without Re-opening Worksheet
Hey, that is a good idea! Not sure if I will use it, but still... very innovative. If I start needing to change the enabled status of my workbooks more often I will certainly use this as a starting place for whatever system I end up implementing. Thank you very much.
Re: Failure to Clear Control References
Well, the "kWorkbookData" object is a project level variable & the variables referencing the combo boxes are members of kWorkbookData, or members of members of kWorkbookData, or... well, you get the picture. So destroying the kWorkbookData object SHOULD start a cascade of Class_Terminate events destroying all of the member objects. Point being there are too many different places that objects are supposed to get destroyed to easily trace what is happening & find out where the reference is not being cleared.
When I hide or delete cells that are referred to by the RowSource property of a combobox in my code is causes all sorts of weird errors. Sometimes it just causes a "catastrophic error" & crashes Excel, but sometimes it lets me debug & I can trace the problem back to the Change event of the combo box being fired.
In any case, I think I found (just by luck) where I was missing a "Set _____ = Nothing" & so have solved the problem (hopefully. I am still crossing my fingers). So I suppose you could count this thread as solved?
Re: Enabling Macros Without Re-opening Worksheet
Well... that is disappointing, though not unexpected. Oh well.
Re: Failure to Clear Control References
Quote from Andy PopeMaybe you could use the watch window in VBE to watch the userform and combobox, espcially when the userform closes and unloads.
How are you closing and unloading the userform?
Yeah, I have thought of using the watch window, but it would be rather complicated (I am using classes & dynamically allocated arrays so it would be a bit tricky to figure out exactly how to reference what I want to reference in the watch window. & I have quite a few controls that I would have to watch...)
I am closing the userform with a command button:
And freeing the memory in the Userform_Terminate event:
kWorkbookData is an instance of the complicated class that I use for... well, pretty much everything in this project.
In C++ I developed a method to save the address of the target memory every time that memory was dynamically allocated or deallocated & then I could compare those two files to see if there was any memory being allocated but not deallocated. I am not really sure if there would be any way to do this with VBA...
I am working on a very complicated project using a userform where I set references to several combo box controls. When I close the userform it should clear all of these references. However, for some reason it is not, & so when I change any data in the sheets to which combo boxes have their rowsource property set, it fires the change event for those combo boxes & causes all sorts of errors since the userform is not open. Is there any good way to track my references so that I can try to figure out why the memory is not being released?
Just wondering... if you open a workbook & choose not to enable macros, is there any way to later change your mind & set macros to enabled without having to close & reopen the workbook?
Re: Scanning Range instead of single cell
So let me see if I have this straight. Is this what you want:
1) When the user enters a value into column 'X' from row 5 to the last data row on the "Approved" sheet, start the procedure for the row into wich the user entered data.
2) Ask the user if he is sure that he wants to process the data
3) If the user says yes, copy the cells in columns B to F, & J to V in that row to the next empty row in
- the "Del 2006" sheet if the value was a 1
- the "Add 2006" sheet if the value was a 2.
4) Add the date that this process took place in column H of the current output row.
5) Delete the value (1 or 2) that the user entered in the "Approved" sheet
Can I assume that the "Del 2006" and "Add 2006" will already be formatted correctly with the proper headers and everything?
Is it really necessary to format the cells? Because when you copy & paste the data from the "Approved" sheet, the format will be copied over too.
Anyways, here is what I have now, check it out & let me know if it works for you.
In the "Approved" worksheet's code module:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lLastRow As Long
Dim rgArea As Range, rgCell As Range
' Find the last row of date in the "Approved" worksheet
lLastRow = FindLastRow(SZ_WS_APPROVED, COL_B)
' Set a reference to the changed cells in column X
Set Target = Intersect(Target, Range(Cells(ROW_FIRST, COL_X), Cells(lLastRow, COL_X)))
' If any cells in column X were changed
If (Not Target Is Nothing) Then
' Disable event handling
Application.EnableEvents = False
' For each area of changed cells in column X
For Each rgArea In Target.Areas
' For each cell in the current area
For Each rgCell In rgArea.Cells
Call CheckX(rgCell.Row)
Next rgCell
Next rgArea
' Enable event handling
Application.EnableEvents = True
End If
End Sub
Display More
In a standard code module:
Option Explicit
Public Const SZ_WS_APPROVED As String = "Approved"
Public Const SZ_WS_DELETE As String = "Del 2006"
Public Const SZ_WS_ADD As String = "Add 2006"
Public Const ROW_FIRST As Long = 5
Public Const COL_B As Integer = 2
Public Const COL_F As Integer = 6
Public Const COL_H As Integer = 8
Public Const COL_J As Integer = 10
Public Const COL_V As Integer = 22
Public Const COL_X As Integer = 24
Public Const CODE_DELETE As Integer = 1
Public Const CODE_ADD As Integer = 2
Public Sub CheckX(lSourceRow As Long)
Dim szMessage As String
Dim szTargetSheet As String
Dim lTargetRow As Long
With Sheets(SZ_WS_APPROVED).Cells(lSourceRow, COL_X)
If IsNumeric(.Value) Then
Select Case .Value
' Deleting a value
Case CODE_DELETE
szMessage = "Are you sure you want to delete?"
szTargetSheet = "Del 2006"
' Adding a Credit
Case CODE_ADD
szMessage = "Is this a new addition?"
szTargetSheet = "Add 2006"
' If an invalid code is given
Case Else
' Do nothing
Exit Sub
End Select
' Ask the user if the procedure should really be run
If (vbYes = MsgBox(szMessage, vbYesNo, "ExcelTips")) Then
' Disable alerts & screen updating
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
' Find the last row of data in the target sheet
lTargetRow = FindLastRow(szTargetSheet, COL_B) + 1
' Copy first part of data
Call CopyData(szTargetSheet, lSourceRow, lTargetRow, COL_B, COL_F)
' Copy second part of data
Call CopyData(szTargetSheet, lSourceRow, lTargetRow, COL_J, COL_V)
' I DO NOT THINK THIS STEP IS NECESSARY, BUT IF YOU WANT IT
' YOU CAN UNCOMMENT THESE LINES
' If this is not the first row of data
'If (ROW_FIRST < lTargetRow) Then
' Format the new cells
'Call FormatCells(szTargetSheet, lTargetRow)
'End If
' Add the date that this procedure was run
Call AddDate(szTargetSheet, lTargetRow)
' Delete the value
.Clear
' Enable alerts & screen updating
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End If
End If
End With
End Sub
Public Function FindLastRow(szSheetName As String, iColumn As Integer) As Long
Dim rgLastCell As Range
With Worksheets(szSheetName)
' Set a reference to the cell in the last row of the given column & sheet
Set rgLastCell = .Cells(.Rows.Count, iColumn)
End With
' If this cell is empty
If (IsEmpty(rgLastCell)) Then
' Change the reference to the last non-empty cell in the given column & sheet
Set rgLastCell = rgLastCell.End(xlUp)
End If
' Return the row of the referenced cell
FindLastRow = rgLastCell.Row
End Function
Private Sub CopyData(szTargetSheet As String, lSourceRow As Long, lTargetRow As Long, iFirstCol As Integer, iLastCol As Integer)
' Copy the data from the "Approved" sheet
With Sheets("Approved")
.Range(.Cells(lSourceRow, iFirstCol), .Cells(lSourceRow, iLastCol)).Copy
End With
' Paste the data to the appropriate output sheet
With Sheets(szTargetSheet)
Call .Paste(Destination:=.Cells(lTargetRow, iFirstCol))
End With
End Sub
Private Sub FormatCells(szTargetSheet As String, lTargetRow As Long)
' Copy the format for the new cells from the previous cells
With Sheets(szTargetSheet)
.Range(.Cells(lTargetRow - 1, COL_B), .Cells(lTargetRow - 1, COL_V)).Copy
Call .Range(.Cells(lTargetRow, COL_B), .Cells(lTargetRow, COL_V)).PasteSpecial(Paste:=xlPasteFormats)
End With
End Sub
Private Sub AddDate(szTargetSheet As String, lTargetRow As Long)
' Add the date to the appropriate row
With Sheets(szTargetSheet).Cells(lTargetRow, COL_H)
.Value = Format(DateTime.Date(), "mm/dd/yyyy")
End With
End Sub
Display More
Re: Scanning Range instead of single cell
Quote from Baller3356I caught that error. This only works for Row 5. The others rows do nothing when I enter in a value. After I enter a value in row 5 it then checks the other rows. How do I make it so it checks the other rows independantly?
Once again I ask, can you please post an example worksheet? Something with the code you are currently using, as well as a good example of what your data is like. An example of what you want the output to be would also be very nice. If you do this, I will take a look at the code & see if I can make it work for you. Without this, it will be a lot harder for me to give you any answers if I even can at all.
As it now stands, the "CheckX" function works for all of the rows in one run of the procedure. If you want to do this for only one row per run of the procedure, then "CheckX" will have to be changed. This is something I can do, but I would still appreciate it if you sent me your example workbook. Thanks.
Re: Sum last 9 cell entries in a row greater than 0
Option Explicit
Function SUMLAST(rgRange As Range, Optional ByVal nCount As Integer = 9) As Long
Dim iLastColumn As Integer, iColumn As Integer
With rgRange
iLastColumn = .Columns.Count - .Column
For iColumn = iLastColumn To .Column Step -1
With .Cells(1, iColumn)
SUMLAST = SUMLAST + .Value
If (.Value <> 0) Then
nCount = nCount - 1
End If
If (nCount = 0) Then
Exit Function
End If
End With
Next iColumn
End With
End Function
Display More
Haha, I threw that together really quickly, so it is pretty messy... hopefully it works! (It should at least give you a starting point.)
Re: Merge Row data, with critera
So does this do what you want? I just changed the bit where it decides whether to sum the data (for numeric data, which changes) or just use the data from the first instance (for strings, which do not change).
Option Explicit
Public Const SZ_INPUT As String = "Criteria"
Public Const SZ_OUTPUT As String = "PrintOut"
Public Const I_FIRST As Integer = 0
Public Const I_LAST As Integer = 1
Public Const I_DATA As Integer = 2
Public Const ROW_HEADER As Long = 11
Public Const ROW_DATA As Long = 12
Public Const ROW_OUTPUT As Long = 13
Public Const COL_FIRST As Integer = 1
Public Const COL_PROJECT As Integer = 2
Public Const COL_FIRSTNUMERIC As Integer = 7
Public Const COL_LAST As Integer = 22
Sub CombineProjectData()
Dim lInputRows(I_FIRST To I_DATA) As Long
Dim lFirstInstance As Long, lOutputRow As Long
Dim szData As String
Dim iCurrColumn As Integer
' Find the rows containing data
Call FindRowArray(lInputRows(), , COL_PROJECT)
With Worksheets(SZ_INPUT)
' Sort the data using the client & project columns
Call .Range(.Cells(lInputRows(I_FIRST), COL_FIRST), _
.Cells(lInputRows(I_LAST), COL_LAST)).Sort( _
Key1:=.Cells(lInputRows(I_FIRST), COL_FIRST), _
Key2:=.Cells(lInputRows(I_FIRST), COL_PROJECT))
' Start with the first
lOutputRow = ROW_OUTPUT
' For each row in the input sheet
For lInputRows(I_DATA) = lInputRows(I_FIRST) To lInputRows(I_LAST)
' Get the name of the project in the current row
szData = .Cells(lInputRows(I_DATA), COL_PROJECT).Value
' Store the current row as the first instance of this project
lFirstInstance = lInputRows(I_DATA)
' Find the last row containing data for this project
Do While (szData = .Cells(lInputRows(I_DATA) + 1, COL_PROJECT).Value)
lInputRows(I_DATA) = lInputRows(I_DATA) + 1
Loop
' For each column of data
For iCurrColumn = COL_FIRST To COL_LAST
' [THIS IS THE BIT THAT I CHANGED TO DEAL WITH THE NON-NUMERIC DATA COLUMNS]
' If the current column is less than the first numeric column
If (COL_FIRSTNUMERIC > iCurrColumn) Then
' Use the data from the first instance of this project
szData = .Cells(lFirstInstance, iCurrColumn).Value
' If the current column is not less than the first numeric column
Else
' Sum the data from all rows for this project
szData = WorksheetFunction.Sum(.Range( _
.Cells(lFirstInstance, iCurrColumn), _
.Cells(lInputRows(I_DATA), iCurrColumn)))
End If
' Write the combined data to the output sheet
Worksheets(SZ_OUTPUT).Cells(lOutputRow, iCurrColumn).Value = szData
Next iCurrColumn
' Move on to the next output row
lOutputRow = lOutputRow + 1
Next lInputRows(I_DATA)
End With
End Sub
Private Sub FindRowArray(lRowArray() As Long, Optional szSheetName As String = SZ_INPUT, Optional iColumn As Integer = COL_FIRST)
' Use the data row as the first row
lRowArray(I_FIRST) = ROW_DATA
' Find the last non-empty row
lRowArray(I_LAST) = FindLastRow(szSheetName, iColumn)
End Sub
Private Function FindLastRow(Optional szSheetName As String = SZ_INPUT, Optional iColumn As Integer = COL_FIRST) As Long
Dim rgLastCell As Range
With Worksheets(szSheetName)
' Select the last cell in the given column of the given sheet
Set rgLastCell = .Cells(.Rows.Count, iColumn)
' If this cell is empty
If (IsEmpty(rgLastCell)) Then
' Select the last non-empty cell in the given column of the given sheet
Set rgLastCell = rgLastCell.End(xlUp)
End If
' Return the last non-empty row in the given column of the given sheet
FindLastRow = rgLastCell.Row
End With
End Function
Display More
Re: loop a script a fixed number of times
When you get that error in a line that refers to a workbook it is because no workbook exists with the name that you are giving. Check out the value of the SZ_WS_TEMPLATE constant (it can be found at the top of the module). Make sure that this string is the same as the name of the sheet holding your template.
Re: loop a script a fixed number of times
That is significantly better, thank you. (Though it would help if your example output was for one of the actual sets of data in your example data.) In any case, I think I have been able to figure out what you are doing here.
A few questions:
Are you sure that setting formulas to refer to the cells in the data sheet is what you want to be doing? (Rather than just copying the cell value...)
Actually, one more question, do you want to run this procedure for the "Total" row as well, or just for each of the employee rows?
Can I assume that the "CPI 2006 q3 simon.xls" & "monthly review.xls" workbooks are in the same folder? It would make things a lot easier if they were.
There does not seem to be any example data in columns U to X for the Call Observations, so I cannot be sure that I did the right things for those.
About the naming of the monthly review files, do you want to use the employee's full name or just their surname?
In any case, this should probably work for you:
Option Explicit
' Names of the workbooks used for this procedure (you can change these if they are different on your computer)
Public Const SZ_WB_SOURCE As String = "CPI 2006 q3 simon.xls"
Public Const SZ_WB_TEMPLATE As String = "monthly review.xls"
' Names of the worksheets used for this procedure (you can change these if they are different on your computer)
Public Const SZ_WS_TEMPLATE As String = "Monthly Review"
' Row constants
Public Const ROW_FIRST As Long = 2
Public Const ROW_NAME As Long = 4
Public Const ROW_KPI_FIRST As Long = 11
Public Const ROW_KPI_SWITCH As Long = 16
Public Const ROW_KPI_LAST As Long = 19
Public Const ROW_OBS_FIRST As Long = 35
Public Const ROW_OBS_LAST As Long = 39
Public Const ROW_OBS_COMP As Long = 41
Public Const ROW_OBS_NONCOMP As Long = 43
' Column constants
Public Const COLUMN_A As Integer = 1
Public Const COLUMN_B As Integer = 2
Public Const COLUMN_C As Integer = 3
Public Const COLUMN_D As Integer = 4
Public Const COLUMN_F As Integer = 6
Public Const COLUMN_H As Integer = 8
Public Const COLUMN_AG As Integer = 33
Public Const COLUMN_AH As Integer = 34
' The difference between the Call Observation row & column
Public Const DIFF_OBS As Integer = 15
Public Sub CreateMonthlyReviews()
Dim szMonth As String
Dim wbSource As Workbook
Dim lLastRow As Long
Dim lCurrRow As Long
Dim szEmployee As String
' Get the name of the current month
szMonth = Strings.LCase(Strings.Format(DateTime.Date(), "mmmm"))
' Attempt to set a reference to the workbook containing the data; on success
If (GetSourceWorkbook(SZ_WB_SOURCE, wbSource)) Then
With wbSource
' Find the last row containing data
lLastRow = FindLastRow(.Worksheets(szMonth), COLUMN_A)
' For each employee row (delete the "- 1" to have this procedure run for the Total row as well)
For lCurrRow = ROW_FIRST To lLastRow - 1
' Get the name of the current user
szEmployee = .Worksheets(szMonth).Cells(lCurrRow, COLUMN_A).Value
' Create the monthly report for the employee in the current row
Call MonthlyReview(.Path, szMonth, szEmployee, lCurrRow)
Next lCurrRow
End With
End If
End Sub
Private Function GetSourceWorkbook(szWBName As String, wbSource As Workbook) As Boolean
' Attempt to set a reference to the workbook with the given name
On Error Resume Next
Set wbSource = Workbooks(szWBName)
On Error GoTo 0
' If the reference was not successfully set
If (wbSource Is Nothing) Then
' Return function failure
GetSourceWorkbook = False
' If the reference was successfully set
Else
' Return function success
GetSourceWorkbook = True
End If
End Function
Private Function FindLastRow(wsToSearch As Worksheet, iColumnToSearch As Integer) As Long
Dim rgLastCell As Range
With wsToSearch
' Set a reference to the very last cell in the given worksheet
Set rgLastCell = .Cells(.Rows.Count, iColumnToSearch)
' If this cell is blank
If (IsEmpty(rgLastCell)) Then
' Change the cell reference to the last non-empty cell in the given column
Set rgLastCell = rgLastCell.End(xlUp)
End If
' Return the row of the referenced cell
FindLastRow = rgLastCell.Row
End With
End Function
Private Sub MonthlyReview(szPath As String, szMonth As String, szEmployee As String, lEmployeeRow As Long)
Dim lRow As Long
Dim iColumn As Integer
' Turn off screen updating (this generally helps to speed up Excel code)
Application.ScreenUpdating = False
' Create the workbook for the monthly report for the current employee
With CreateWorkbook(szPath, szEmployee, szMonth)
With .Worksheets(SZ_WS_TEMPLATE)
' Set the reference for the employee's name
.Cells(ROW_NAME, COLUMN_B).FormulaR1C1 = ConstructFormula(szMonth, lEmployeeRow, COLUMN_A)
' Initialize the column for the KPI Objective cells
iColumn = COLUMN_H
' For each KPI Objective row
For lRow = ROW_KPI_FIRST To ROW_KPI_LAST
' Set the references for the current KPI Objective row
.Cells(lRow, COLUMN_C).FormulaR1C1 = ConstructFormula(szMonth, lEmployeeRow, iColumn)
.Cells(lRow, COLUMN_D).FormulaR1C1 = ConstructFormula(szMonth, lEmployeeRow, iColumn + 1)
' Determine the next column based on the current row
Select Case lRow
' If the current row is less than the switch row
Case Is < ROW_KPI_SWITCH
' Increment the column by 2
iColumn = iColumn + 2
' If the current row is equal to the switch row
Case ROW_KPI_SWITCH
' Switch the column
iColumn = COLUMN_F
' If the current row is greater than the switch row
Case Else
' Decrement the column by 2
iColumn = iColumn - 2
End Select
Next lRow
' For each Call Observation row
For lRow = ROW_OBS_FIRST To ROW_OBS_LAST
' Set the reference for the current Call Observation row
.Cells(lRow, COLUMN_B).FormulaR1C1 = ConstructFormula(szMonth, lEmployeeRow, lRow - DIFF_OBS)
Next lRow
' Set the reference for the % of Competent Observations
.Cells(ROW_OBS_COMP, COLUMN_C).FormulaR1C1 = ConstructFormula(szMonth, lEmployeeRow, COLUMN_AG)
' Set the reference for the % of Non-Compliant Observations
.Cells(ROW_OBS_NONCOMP, COLUMN_C).FormulaR1C1 = ConstructFormula(szMonth, lEmployeeRow, COLUMN_AH)
End With
' Save the changes & close the workbook
Call .Close(True)
End With
' Turn screen updating back on
Application.ScreenUpdating = True
End Sub
Private Function CreateWorkbook(szPath As String, szEmployee As String, szMonth As String) As Workbook
Dim szFileName As String
Dim wbToReturn As Workbook
Dim iCommaPos As Integer
' Construct the file name of the template workbook
szFileName = szPath & "\" & SZ_WB_TEMPLATE
' If the template workbook is not already open
If (Not WorkbookExists(SZ_WB_TEMPLATE, wbToReturn)) Then
' Open the template workbook
Set wbToReturn = Workbooks.Open(Filename:=szFileName)
End If
' Extract the employee's surname (uncomment this if you want to use just the employee's surname
'iCommaPos = Strings.InStr(1, szEmployee, ",")
'szEmployee = Strings.Left(szEmployee, iCommaPos - 1)
' Construct the name of the workbook
szFileName = Strings.Replace(szFileName, ".xls", " " & szEmployee & " " & szMonth & ".xls")
' Save the workbook with the appropriate name
Call wbToReturn.SaveAs(Filename:=szFileName)
' Return the new workbook
Set CreateWorkbook = wbToReturn
End Function
Function WorkbookExists(szWBName As String, Optional wbToReturn As Workbook) As Boolean
' Attempt to set a reference to the workbook with the given name
On Error Resume Next
Set wbToReturn = Workbooks(szWBName)
On Error GoTo 0
' If the reference was not set
If (wbToReturn Is Nothing) Then
' Return false
WorkbookExists = False
' If the reference was set
Else
' Return true
WorkbookExists = True
End If
End Function
Function ConstructFormula(szMonth As String, lRow As Long, iColumn As Integer) As String
' Construct a formula to refer to the cell with the given row & column in the source workbook
ConstructFormula = "='[" & SZ_WB_SOURCE & "]" & szMonth & "'!R" & lRow & "C" & iColumn
End Function
Display More
Try it out & let me know how it works!
Re: loop a script a fixed number of times
Um, I do not mean to be rude, but that is a pretty useless example file. Just one sheet with an empty table with headings that mean nothing to me? If you upload another example sheet, this time with data (it does not have to be actual data, just make up some good examples that is at least representative of what kind of data you will be expecting in your form), as well as including the macros as you currently have them (at least the copy macros for at least two rows so that I can figure out what changes & what stays the same between the different row copying macros), & (most importantly) an example, constructed by hand, of what output you want to achieve with the example data that you provide me, then I will be more than happy to help you. I apologize once again if I am coming off as rude, but this example workbook of yours tells me absolutely nothing about what you are trying to do & so is no help in me helping you.
Re: Merging two identical spreadsheets?
No problem, let me know how it works!