I've ended up creating several macros for work recently, some of which took a bit of research, so I thought I should share them here.
This is not the most elegant code in the world. I was asked to do a load of jobs involving repetitive, tedious and precise changes to large numbers of spreadsheets, with quite short deadlines for turnaround. It was also not clear how many there'd be in the future. In this situation, spending a lot of time producing beautiful, elegant, foolproof, robust code is a mug's game, and I'd just have missed my deadlines. Instead, I hacked together something that would work.
In a few cases I've tried to make things flexible or robust, but others are rigid. One issue is, of course, that unless you've got good information on the data you're going to be working on, you can't make things that robust. For example, it often:
- wasn't possible to establish how many rows or columns might be involved
- wasn't possible to guarantee that columns would have exactly the same names
- wasn't possible to guarantee unique terms in any column title
- wasn't possible to guarantee that data would come with particular formats
- wasn't possible to guarantee clean data
This sort of this puts the kibosh on many techniques for automatically selecting data for processing, but I did my best.
Find and replace macro
Sub Nullify()
'
' Removes NULL from workbook
'
Cells.Replace What:="NULL", Replacement:="", lookat:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
Replace value in a single column
Sub Dating()
'changes date values and formats that still show the default value 01011900
Dim lngRow As Long
Dim BotRow As Long
'selects the last used cell in column Y, without using the problematic "UsedRange" group of properties
Cells(Rows.Count, "Y").Select
'select all cells above this cell, i.e. all of column Y that might contain data
Selection.End(xlUp).Select
BotRow = Selection.Row
For lngRow = 1 To BotRow
'straightforward replacement of text
If Cells(lngRow, "Y") = "01011900" Then
Cells(lngRow, "Y") = "NOT"
End If
Next
End Sub
Insert new fields in predictable places
As is often the case, this isn't the most elegant way to achieve something - in this case, repeatedly calling the same function. However, it is extremely simple and very easy to error test, compared to anything involving looping through arrays.
Sub New_Fields()
'inserts new fields by calling Insertion repeatedly
Dim Ws As Worksheet
Set Ws = ActiveSheet
Call Insertion("Surname", "Surname and Initials")
Call Insertion("dept", "preferredDept")
'...etc
End Sub
Sub Insertion(LookFor As String, Entitle As String)
'inserts a column to the left of a specified existing column
Dim t As Range
'search the top row
With ActiveSheet.Rows(1)
'find a column called "LookFor"
Set t = .Find(LookFor, lookat:=xlWhole)
If Not t Is Nothing Then
'when found, insert a new column to the left with name=Entitle
Columns(t.Column).EntireColumn.Select
ActiveCell.EntireColumn.Insert
ActiveCell.Value = Entitle
End If
End With
End Sub
Populate a blank field by concatenating existing fields
Sub Concatenate_Name()
'creates the "Surname and Initials" field based on existing fields
Dim sur As Range
Dim ini As Range
Dim rangeList As String
Dim r As Range
'search the top row
With ActiveSheet.Rows(1)
Set sur = .Find("Surname", lookat:=xlWhole)
If Not sur Is Nothing Then
Set ini = .Find("Inits", lookat:=xlWhole)
If Not ini Is Nothing Then
'find a column called "Surname"
Set t = .Find("Surname and Initials", lookat:=xlWhole)
If Not t Is Nothing Then
'when found, create a range based on this column
Let rangeList = t.Column & t.Row & ":" & ActiveSheet.UsedRange.Rows.Count & t.Column
'select a range from the top of the found column, to the end of this column; the following code picks the last row number used on the sheet, which is a passable proxy
Set r = Range(Cells(t.Row, t.Column), Cells(ActiveSheet.UsedRange.Rows.Count, t.Column))
For Each Cell In r
'activate that cell so it can pull in the corresponding name details
Cell.Activate
If Cell.Value = "" Then
'if blank, concatenate the values from the existing name cells
PartOne = Cells(ActiveCell.Row, sur.Column)
PartTwo = Cells(ActiveCell.Row, ini.Column)
Cell.Value = (PartOne & ", " & PartTwo)
End If
Next
End If
End If
End If
End With
'freeze the sheet so the top row and the new "Surname and Initials" column are visible
Cells(t.Row + 1, t.Column + 1).Activate
ActiveWindow.FreezePanes = True
End Sub
Rename columns
Sub Fix_Names()
'renames fields from exports to match those required by departments.
'call a load of instances of Change_Name with the appropriate parameters
Call Change_Name("ABC", "abc")
Call Change_Name("Multiple Submission", "multipleSubmission")
'...and so ad infinitum
End Sub
Sub Change_Name(LookFor As String, Alter As String)
'changes the value in a top-row cell
Dim t As Range
'search the top row
With ActiveSheet.Rows(1)
'find a column called "LookFor"
Set t = .Find(LookFor, lookat:=xlWhole)
If Not t Is Nothing Then
'when found, replace the cell's value with the value of Alter
Cells(1, t.Column).Value = Alter
End If
End With
End Sub
Changing borders and colours
A weird one. There were some quite specific formats demanded in terms of how some spreadsheets looked, and doing this by hand (and checking you'd done it) was a pain. Nobody will be copy-pasting this, but you might find something relevant in here.
Sub Decorator()
'
' Decorator Macro
' Changes the format of grids and cells
'
'select all cells
ActiveSheet.UsedRange.Select
'remove existing borders and add new grey ones
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
'sets the left border to be continuous thin grey
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
'and so on for the other borders
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
'main body cells
Range("C5").Activate
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Name = "Tahoma"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
'headers
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
'sets columns to be various colours
Call Colourize
End Sub
Sub Colourize()
Dim myColour As String
'set all the headers to various colours, but leave other cells as some rows contain highlighting of some kind - at least it'll persist in the white columns
Range(Cells(1, 1), Cells(1, ActiveSheet.UsedRange.Columns.Count)).Select
Selection.Interior.ColorIndex = 2
'go through an array of column names, and call the Colourer function with the name and a set of RGB values
greys = Array("div", "dept", "staff") 'and so on
For i = LBound(greys) To UBound(greys)
myColour = greys(i)
Call Colourer(myColour, 191, 191, 191)
Next i
loranges = Array("startdate", "startcon", "contrend") 'and so on
For i = LBound(loranges) To UBound(loranges)
myColour = loranges(i)
Call Colourer(myColour, 253, 253, 217)
Next i
'and you get the idea - there's quite a few of these in the full version
End Sub
Sub Colourer(LookFor As String, ColourR As Integer, ColourG As Integer, ColourB As Integer)
'changes the fill colour of a column
Dim t As Range
'search the top row
With ActiveSheet.Rows(1)
'find a column called "LookFor"
Set t = .Find(LookFor, lookat:=xlWhole)
If Not t Is Nothing Then
'make that column the chosen colour
Columns(t.Column).EntireColumn.Select
Selection.Interior.Color = RGB(ColourR, ColourG, ColourB)
End If
End With
End Sub
No comments:
Post a Comment