These are some more macros that I used heavily during a recent project. As some took quite a bit of effort to create, I thought I'd post them in case they can be reused by someone else - or for my own future reference, of course.
Dealing with near-duplicate columns
It's quite common for people to design a spreadsheet with, say, Error Code as a column, then later to realise that a record might end up with more than one error codes, and deal with this by simply creating Error Code 2 on the same row. In our case, I needed to end up with a set of records where each error code was in the same one column, but had its own row, duplicating the rest of the data for the record. There was a lot of data to go through.
The multi-part macro below can do this. It goes through each row from the bottom of the data up*, finds columns with a particular name in the top row (in this case, those containing "Error Code") and checks for values in them. If any cells have values, it'll create a new row for each column containing a value, copy the original row's data across, and set "Error Code 1" to equal the Error Code value in the cell it's working from. When all the target cells have been processed, the original row of data is deleted.
*if you're inserting new rows below your current row, this is a key safeguard to stop your macro getting caught in a loop where it inserts a new row, then processes that new row and adds another... never moving on to the second of the original rows.
Even if the main macro isn't useful to you, you might find one of the subparts useful.
Sub SplitByDupeColumn()
'takes a sheet where there are several columns containing equivalent information and splits them so each one has its own record, filling in the rest of the data from the original row. For example where someone has created four "Error Code" columns to allow for up to four error codes in a record. Here you are really dealing with a one-to-many relationship. Having a separate row for each record is much neater.
Dim rgAll As Range
Dim myRow As Long
Set rgAll = Range(Cells(2, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
'this can be a very long operation, so as long as we know it works, don't bother updating the screen - it'll only slow us down
Application.ScreenUpdating = False
With ActiveSheet
'start at the end and go backwards. This way it isn't disrupted by new rows being added below the one we're processing
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
'messy workaround because it won't accept i as an argument for some reason
myRow = i
Call ColToRow(myRow, "Error Code")
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub ColToRow(someNumber As Long, myField As String)
'for a sheet with several columns whose titles contain the same string, takes one row and turns it into one row per entry in that set of columns
'e.g. if you have Notes1 Notes2 Notes3, it will turn one row (with data in each field) into three rows, each of which only has data in one of these fields,
'but contains all the rest of the data for that row.
'Blanks are ignored. The original row is deleted.
Dim myRange As Range
Dim colInd As Integer
Dim newCellRow As Integer
Dim newCellCol As Integer
'messy workaround because the calling subroutine is based on a Long but we want an Integer
Dim lngRow As Integer
lngRow = someNumber
'find those cells that are in "Error Code" columns
Call CellPicker(myField, lngRow)
Set myRange = Selection
'if value in any Error Code column, add new row for each, then delete the original
For Each myCol In myRange.Columns
If Not IsEmpty(myCol.Value) Then
'get the index of this column so you can insert the value later
colInd = myCol.Column
'add a new row
Cells(lngRow + 1, 1).EntireRow.Insert
'copy down the data from the original row
Range(Cells(lngRow, 1), Cells(lngRow + 1, ActiveSheet.UsedRange.Columns.Count)).FillDown
'copy down the Circ Id value for this column
'get the new cell where you want to store the values
Call CellPicker("Error Code1", lngRow + 1)
Selection.Value = Cells(lngRow, colInd).Value
Cells(lngRow + 1, colInd).Value = Cells(lngRow, colInd).Value
'blank out the Error Code values in all columns except this one in the row we just created
Call BlankMe(myRange, lngRow + 1, Cells(lngRow, colInd))
End If
Next myCol
''myRange.Select
Cells(lngRow, 1).EntireRow.Delete
End Sub
Sub BlankMe(myRange As Range, lngRow As Integer, leaveMe)
'blanks all but one column on one row in a stated range
Dim colInd As Integer
For Each myCol In myRange.Columns
'unless it's the column we want to keep, blank it
If Not myCol.Column = leaveMe.Column Then
colInd = myCol.Column
Cells(lngRow, colInd).Value = Null
End If
Next myCol
End Sub
Sub CellPicker(LookFor As String, lngRow As Integer)
'picks cells in one row (lngRow), based on the headers for that column
'set variables
Dim rgToCheck As Range
Dim rgSelect As Range
Dim cl As Range
'build a range from cells called LookFor
With ActiveSheet.Rows(1)
'find a column called "LookFor"
'select the top row
Set rgToCheck = Range(Cells(1, 1), Cells(1, ActiveSheet.UsedRange.Columns.Count))
For Each cl In Intersect(ActiveSheet.UsedRange, rgToCheck)
'select any columns containing the desired text LookFor, except for the header row (this exclusion probably not strictly necessary, but neater)
If InStr(1, cl.Text, LookFor) Then
If rgSelect Is Nothing Then
Set rgSelect = Range(Cells(lngRow, cl.Column), Cells(lngRow, cl.Column))
Else
Set rgSelect = Union(rgSelect, Range(Cells(lngRow, cl.Column), Cells(lngRow, cl.Column)))
End If
End If
Next cl
If Not rgSelect Is Nothing Then
rgSelect.Select
End If
End With
End Sub
Protection
This next one comes from the way worksheets were handled in part of the project. Colour-coding was used to indicate the type of data in a cell: many types were not to be changed by the main users. The spec called for white and grey cells to be locked, and doing this by hand was predictably painful since the colours were scattered across sheets and mixed with other colours. The following macro locks white and grey (191,191,191) cells only.
Sub Lock_Grey_White_Values()
Dim rgToCheck As Range
Dim rgSelect As Range
Dim cl As Range, myColorIndex As Long
'check the entire sheet
Set rgToCheck = Range(Cells(1, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
'white cells = index2
myColorIndex = 2
'build a range from cells with white colour
For Each cl In Intersect(ActiveSheet.UsedRange, rgToCheck)
If cl.Interior.ColorIndex = myColorIndex Then
If rgSelect Is Nothing Then
Set rgSelect = cl
Else
Set rgSelect = Union(rgSelect, cl)
End If
End If
Next cl
'now add grey cells - no handy index, so use RGB 191
For Each cl In Intersect(ActiveSheet.UsedRange, rgToCheck)
If cl.Interior.Color = RGB(191, 191, 191) Then
If rgSelect Is Nothing Then
Set rgSelect = cl
Else
Set rgSelect = Union(rgSelect, cl)
End If
End If
Next cl
If rgSelect Is Nothing Then
MsgBox "The Colorindex " & myColorIndex & " hasn't been found."
Else
rgSelect.Select
End If
Selection.Locked = True
Selection.FormulaHidden = True
End Sub
The next one was used to save a password-protected copy of the file in a new location, saving multiple clicks per use and avoiding typing errors. Only limited security was needed on these files, so having a common password for many files didn't matter. It was only to protect them from casual inspection.
Sub Parallel_Save()
'saves protected version of the workbook in a new location
Dim NewName As String
Dim MyPath As String, MyCompletePath As String
'save workbook with password in corresponding folder of new location
MyPath = ActiveWorkbook.Path
NewPath = Replace(MyPath, "Unprotected", "Protected")
NewName = NewPath & "\" & ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:=NewName, Password:="password"
MsgBox "The new version has been saved; don't save this one!"
End Sub
This slightly stronger version protected and saved the files, so that not only was a password needed, but separate password access was needed to change locked cells.
Sub Protected_Save()
'saves protected version of the workbook with password filepass, and protects the active sheet as sheetpass, with locked cells protected
ActiveSheet.Unprotect Password:="sheetpass"
Call GetLocks
Dim myRange As Range
Dim NewName As String
Dim MyPath As String
'protect the worksheet
ActiveSheet.Protect "sheetpass", AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
'Allow 'Protect worksheet and contents of locked cells', 'Select locked cells', 'Select unlocked cells', 'Format cells', 'Format columns', Format rows', 'Sort', and 'Use AutoFilter'.
'save workbook with new password
NewName = ActiveWorkbook.Name
MyPath = "C:\Example"
NewName = MyPath & "\" & NewName
ActiveWorkbook.SaveAs Filename:=NewName, Password:="filepass"
End Sub
This next one simply unlocks a whole worksheet.
Sub Delock()
'unlocks the whole worksheet
'select all cells
ActiveSheet.UsedRange.Select
Selection.Locked = False
Selection.FormulaHidden = False
End Sub
No comments:
Post a Comment