' General declarations



Sub ReD()

'

Dim dupCol As Range, currentCell As Range, nextCell As Range

Dim dupColAddress As String, dupColstart As String

Dim response As Integer

Dim colCount As Integer

Dim msg As String, boxButtons As Integer

'

Application.Windows("PERSONAL.XLS").Visible = False

Hides ‘Personal.xls’

If Not CheckProc("Remove Duplicates") Then Exit Sub

Do

msg = "Select ONE cell in column of duplicates"

Show message with statement above

Set dupCol = Application.InputBox(prompt:=msg, _

Title:="Selection of Duplicates Column", Type:=8)

Let the dupCol= The Column of the cell selected.

colCount = dupCol.Columns.Count

If colCount 1 Then

MsgBox "Too many columns selected. Select only ONE"

End If

Loop Until colCount = 1

Count number of columns in dupCol, If it isn’t 1 show message box with statement above, continue until only 1 column is selected.

dupColAddress = Mid(dupCol.Address, 2, 2)

If Mid(dupColAddress, 2, 1) = "$" Then

dupColAddress = Left(dupColAddress, 1)

End If

' boxButtons = vbYesNo + vbDefaultButton1 + vbQuestion

msg = "Duplicate entries in Column " & dupColAddress

response = MsgBox(prompt:=msg, Title:="Duplicates Column", _

Buttons:=boxButtons)

If response = vbNo Then Exit Sub

' Show message box with the above statement, If response is No, exit the macro.

' MsgBox "Sort Key = " & dupCol.Address

dupColstart = dupColAddress & "1"

ActiveSheet.UsedRange.Sort _

key1:=ActiveSheet.Range(dupColstart), header:=xlYes

Set currentCell = ActiveSheet.Range(dupColstart)

Application.ScreenUpdating = False

'

Do While Not IsEmpty(currentCell)

Set nextCell = currentCell.Offset(1, 0)

If nextCell.Value = currentCell.Value Then

currentCell.EntireRow.Delete

End If

Set currentCell = nextCell

Loop

Only do the following function when the current cell isn’t empty. Let the next cell be one row down from the current cell. If the next cell equals the current cell, delete the entire row. Continue doing this.

Application.ScreenUpdating = True

ActiveSheet.UsedRange.Sort _

key1:=ActiveSheet.Range(dupColstart), header:=xlYes

Application.ScreenUpdating = True

MsgBox "Duplicate removals finished"

'

End Sub

Sort the range used before using dupColstart as the first Key. Show message box with statement above.

XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

' General declarations

Option Explicit

Option Base 1

'

Dim masterBook As Workbook ' starting workbook object

Dim slaveBook As Workbook 'slave workbook

Dim masterFile As String ' Store master file

Dim slaveFile As String

Dim moduleName As String

Dim moduleFile As String

Dim myRange As Range, database As Range

Dim myCol As Object

Dim myRow As Object

Dim tempObject As Object

Dim foundCell As Range

Dim foundCellAddress As String

Dim msg As String

Dim response As Integer ' response from msgBox or InputBox

Dim boxButtons As Integer 'number for box buttons

Dim newRow As Integer, oldRow As Integer

Dim firstRow As Integer, lastRow As Integer, rowCount As Integer

Dim firstCol As Integer, lastCol As Integer, colCount As Integer

Dim iCol As Integer, iRow As Integer

Dim xTemp As Variant

Dim itemp As Integer

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub LMR()

Dim lastChart As Object

Dim printRange As Range

Dim listFile As String, listName As String

Dim histRange As Range

Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range

Dim iCol As Integer, printRow As Integer, printCol As Integer

Dim histRow As Integer

Dim foundCellx As Single, foundCelly As Single

Dim endCellx As Single, endCelly As Single

Dim chartWidth As Single, chartHeight As Single, chartIndex As Integer

Dim sortMode As String, colourMark As String

Dim colOk As Boolean, colourMode As Boolean

'

msg = "Run procedure to list module results?"

boxButtons = vbYesNo + vbDefaultButton1 + vbQuestion

response = MsgBox(prompt:=msg, Title:="Run Procedure", _

Buttons:=boxButtons)

If response = vbNo Then Exit Sub

Show message box with above statement, including Yes and No buttons.

SetDirectory

Set masterBook = ActiveWorkbook

masterFile = UCase(masterBook.Name)

moduleName = Left(masterFile, 8)

Set myRange = masterBook.ActiveSheet.Range("A1").CurrentRegion

rowCount = myRange.Rows.Count

lastCol = myRange.Columns.Count

Let rowCount= number of rows in myRange and colCount=number of columns in myRange

listFile = "LIST" & Mid(masterFile, 5)

listName = Left(listFile, 8)

colourMark = Mid(masterFile, 5, 1)

If FileExists(listFile) Then

Set slaveBook = Workbooks.Open(filename:=listFile)

slaveBook.ActiveSheet.UsedRange.ClearContents

If ActiveSheet.ChartObjects.Count > 0 Then _

ActiveSheet.ChartObjects.Delete

slaveFile = UCase(slaveBook.Name)

Clears data/formulas of ‘used range’. If there are any chart objects; delete them. Converts slaveFile to uppercase.

Else

Set slaveBook = Workbooks.Add

With slaveBook

.ActiveSheet.Cells.Font.Size = 8

.Title = listName

.Subject = listName & " listing of " & masterFile & _

" results file"

.Author = "D.N.Tovee"

.Keywords = listName & " results"

.SaveAs filename:=listName, FileFormat:=xlNormal, _

CreateBackup:=True

' MsgBox "SaveAs " & listName

slaveFile = UCase(.Name)

End With

Specifies slaveBook with the above statements e.g. Font size=8

Shows Message box to prompt saving the file.

End If

Windows(masterFile).Activate

Activates Masterfile window.

Application.ScreenUpdating = False

With masterBook.ActiveSheet

.Range(Cells(1, 12), Cells(rowCount, 12)).Copy

slaveBook.ActiveSheet.Range("A1").PasteSpecial

Copy cells stated and pastes them in A1 in the slaveFile

.Range(Cells(1, 15), Cells(rowCount, 16)).Copy

slaveBook.ActiveSheet.Range("B1").PasteSpecial

.Range(Cells(1, 21), Cells(rowCount, 21)).Copy

slaveBook.ActiveSheet.Range("D1").PasteSpecial

.Range(Cells(1, 11), Cells(rowCount, 11)).Copy

slaveBook.ActiveSheet.Range("E1").PasteSpecial

.Range(Cells(1, 10), Cells(rowCount, 10)).Copy

slaveBook.ActiveSheet.Range("F1").PasteSpecial

.Range(Cells(1, 4), Cells(rowCount, 4)).Copy

slaveBook.ActiveSheet.Range("G1").PasteSpecial

.Range("AC1").Select

End With

Does the same for columns B1-G1

Application.ScreenUpdating = True

Do

Set foundCell = Application.InputBox( _

prompt:="Select cell in last column to be printed" _

& Chr(10) & "( > AB )", _

Title:="Final Print Column Selection", Type:=8)

printCol = foundCell.Column

colOk = True

If printCol < 29 Or printCol > lastCol Then

MsgBox "Invalid column selected. Try again"

colOk = False

End If

Loop Until colOk

Asks user to select cell in last column to be printed. The printCol must be less than 29 and more than lastCol otherwise it retries the If function.

masterBook.ActiveSheet.Range(Cells(1, 29), _

Cells(rowCount, printCol)).Copy

slaveBook.ActiveSheet.Range("H1").PasteSpecial Paste:=xlValues

Copies from first cell in last column and pastes them in slaveBook

Windows(slaveFile).Activate

Windows.Arrange ArrangeStyle:=xlCascade

Application.ScreenUpdating = False

Range("A1").Select

Set database = ActiveSheet.Range("A1").CurrentRegion

rowCount = database.Rows.Count

colCount = database.Columns.Count

Set r1 = ActiveSheet.Range("A1").Range(Cells(1, 1), _

Cells(rowCount - 1, colCount))

Set r2 = ActiveSheet.Range(Cells(2, 10), _

Cells(rowCount, colCount))

Selects range of A1. Let database= the region previously selected, let rowCount = number of rows in database and colCount = number of columns in database.

r2.NumberFormat = "0.0"

With database

.Rows(rowCount).EntireRow.NumberFormat = "0.0"

.Font.Size = 8

.Columns.AutoFit

.Columns("A").ColumnWidth = 4.86 'Poscode

.Columns("B").ColumnWidth = 3.57 'Qualcode

.Columns("C").ColumnWidth = 1.57 'Yrcode

.Columns("D").ColumnWidth = 3.57 'studmode

' For iCol = 10 To colCount

' .Columns(iCol).NumberFormat = "0.0"

' Next iCol

End With

Specifies formatting of database; Format numbers to 1 decimal place, make the font size 8. Adjust the column widths and add titles to the column.

Do

msg = "C = Sort by Candno" & Chr(10) & _

"P = Sort by Poscode, Surname, Inits" & Chr(10) & _

"S = Sort by Surname, Inits" & Chr(10) & _

"M = Sort by Mark order"

sortMode = InputBox(prompt:=msg, Title:="Sort Mode")

Loop Until sortMode ""

sortMode = UCase(sortMode)

If sortMode "C" Then

If sortMode = "P" Then

r1.Sort key1:=r1.Range("A1"), order1:=xlAscending, _

key2:=r1.Range("F1"), order2:=xlAscending, _

Key3:=r1.Range("E1"), Order3:=xlAscending, _

header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom

If sort mode is P i.e. P is pressed, sort the data with the first key being A1 ascending, second key F1 ascending and third key E1 ascending.

ElseIf sortMode = "S" Then

r1.Sort key1:=r1.Range("F1"), order1:=xlAscending, _

key2:=r1.Range("E1"), order2:=xlAscending, _

header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom

ElseIf sortMode = "M" Then

r1.Sort key1:=r1.Range("I1"), order1:=xlDescending, _

key2:=r1.Range("F1"), order2:=xlAscending, _

Key3:=r1.Range("E1"), Order3:=xlAscending, _

header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom

Else

MsgBox "Invalid sort selection, NO sorting done"

End If

If P,C,M or S isn’t selected show above message box.

End If

Columns("I:I").Select

Selection.FormatConditions.Delete

Deletes the formatting on columns ‘I:I’

If colourMark = "1" Or colourMark = "2" Then

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _

Formula1:="25", Formula2:="34"

With Selection.FormatConditions(1).Font

.Bold = True

.Italic = True

.ColorIndex = 5

End With

Changes formatting conditions to those stated above e.g. bold, italic and color index 5.

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _

Formula1:="25"

With Selection.FormatConditions(2).Font

.Bold = True

.Italic = False

.ColorIndex = 3

End With

Else

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _

Formula1:="35"

With Selection.FormatConditions(1).Font

.Bold = True

.Italic = False

.ColorIndex = 3

End With

End If

Columns("H:H").Select

Does a similar process of changing the formatting for columns ‘H:H’

Selection.FormatConditions.Delete

Selection.FormatConditions.Add Type:=xlExpression, _

Formula1:="=LEFT(H1,1)=""F"""

With Selection.FormatConditions(1).Font

.Bold = True

.Italic = False

.ColorIndex = 3

End With

Selection.FormatConditions.Add Type:=xlExpression, _

Formula1:="=LEFT(H1,1)=""H"""

With Selection.FormatConditions(2).Font

.Bold = True

.Italic = True

.ColorIndex = 5

End With

Adds a formula to show the contents of the cell on the left, also changes formatting conditions.

Set foundCell = Range(Cells(rowCount + 2, 1), _

Cells(rowCount + 2, 1))

With foundCell

.Select

histRow = .Row

.Value = 4

itemp = .Value

.Offset(10, 0).Value = 100

foundCelly = .Top

foundCellx = .Offset(0, 2).Left

endCelly = .Offset(12, 0).Top

endCellx = .Offset(0, 10).Left

For iRow = 1 To 9

.Offset(iRow, 0) = itemp + 10 * iRow

Next iRow

End With

Set r1 = foundCell.Offset(0, 1).Range(Cells(1, 1), Cells(11, 1))

r1.FormulaArray = _

"=FREQUENCY(R2C9:R" & rowCount - 1 & _

"C9,R" & histRow & "C[-1]:R" & histRow + 10 & "C[-1])"

Set r2 = foundCell.Range(Cells(1, 1), Cells(11, 2))

chartHeight = endCelly - foundCelly

chartWidth = endCellx – foundCellx

Specifies chartHeight and chartWidth in terms of previously defined quantities.

ActiveSheet.ChartObjects.Add(foundCellx, _

foundCelly, chartWidth, chartHeight).Select

' Application.CutCopyMode = False

ActiveChart.ChartWizard Source:=r2, Gallery:=xlColumn, _

Format:=6, PlotBy:=xlColumns, CategoryLabels:=1, _

HasLegend:=2, CategoryTitle:="Final mark"

Create a Column chart titled Final mark using date from ‘r2’

Set foundCell = foundCell.Offset(12, 0)

With foundCell

.Select

histRow = .Row

.Value = 24

foundCelly = .Top

foundCellx = .Offset(0, 2).Left

endCelly = .Offset(10, 0).Top

endCellx = .Offset(0, 10).Left

For iRow = 1 To 6

Select Case iRow

Case 1

.Offset(iRow, 0) = 34

Case 2 To 5

.Offset(iRow, 0) = 19 + 10 * iRow

Case 6

.Offset(iRow, 0) = 100

End Select

Next iRow

End With

Set r1 = foundCell.Offset(0, 1).Range(Cells(1, 1), Cells(7, 1))

r1.FormulaArray = _

"=FREQUENCY(R2C9:R" & rowCount - 1 & _

"C9,R" & histRow & "C[-1]:R" & histRow + 6 & "C[-1])"

' Set r2 = foundCell.Range(Cells(1, 1), Cells(7, 2))

chartHeight = endCelly - foundCelly

chartWidth = endCellx - foundCellx

ActiveSheet.ChartObjects.Add(foundCellx, _

foundCelly, chartWidth, chartHeight).Select

' Application.CutCopyMode = False

ActiveChart.ChartWizard Source:=r2, Gallery:=xlColumn, _

Format:=6, PlotBy:=xlColumns, CategoryLabels:=1, _

HasLegend:=2, CategoryTitle:="Degree class"

Create a Column chart with source data from r2 titled degree class.

ActiveCell.Select

Application.ScreenUpdating = True

CalcAutomatic

foundCell.Offset(-12, 0).Select

' Application.ScreenUpdating = False

ActiveSheet.Range("A1").Select

printRow = rowCount + 23

'

boxButtons = vbYesNo + vbDefaultButton1 + vbQuestion

response = MsgBox(prompt:="Make Exam/Coursework scatter plot?", _

Buttons:=boxButtons)

Show message box

If response = vbYes Then

' iCol = Application.InputBox(prompt:="Enter maximum coursework" _

& Chr(10) & "10, 15 or 20", Title:="Coursework maximum", _

Type:=1)

' Set foundCell = foundCell.Offset(11, 0)

With foundCell

.Select

.Value = 0

.Offset(1, 0).Value = iCol / 2

.Offset(2, 0).Value = iCol

.Offset(0, 1).Value = 0

.Offset(1, 1).Value = 50

.Offset(2, 1).Value = 100

foundCelly = .Top

endCelly = .Offset(21, 0).Top

foundCellx = .Offset(0, 2).Left

endCellx = .Offset(0, 10).Left

End With

chartHeight = endCelly - foundCelly

chartWidth = endCellx - foundCellx

Set r3 = ActiveSheet.Range("A1").Range(Cells(1, 10), _

Cells(rowCount - 1, 11))

' Set lastChart = ActiveSheet.ChartObjects.Add(foundCellx, foundCelly, _

chartWidth, chartHeight)

lastChart.Select

chartIndex = lastChart.Index

' MsgBox " chartIndex = " & chartIndex

Application.CutCopyMode = False

ActiveChart.ChartWizard Source:=r3, Gallery:=xlXYScatter, Format:=3, _

PlotBy:=xlColumns, CategoryLabels:=1, SeriesLabels:=1, _

HasLegend:=2, Title:="Exam/Coursework correlation", _

CategoryTitle:="Coursework", ValueTitle:="Exam%"

If response to message box is yes, create a scatter chart titled Exam/Coursework correlation. If no is selected, don’t.

Set r4 = foundCell.Range(Cells(1, 1), Cells(3, 2))

r4.Copy

' ActiveSheet.DrawingObjects("Chart chartIndex").Select

ActiveSheet.ChartObjects(chartIndex).Select

ActiveChart.SeriesCollection.Paste Rowcol:=xlColumns, _

SeriesLabels:=False, CategoryLabels:=True, Replace:=False, _

NewSeries:=True

Paste the values of r4 into chartIndex (scatter plot) as a new series.

Application.CutCopyMode = False

ActiveSheet.ChartObjects(chartIndex).Activate

ActiveChart.SeriesCollection(2).Select

With Selection

.MarkerSize = 2

.MarkerStyle = xlCircle

End With

ActiveChart.SeriesCollection(2).Trendlines.Add(Type:=xlLinear, _

Forward:=0, Backward:=0, DisplayEquation:=False, _

DisplayRSquared:=False).Select

ActiveChart.Axes(xlCategory).Select

Add a linear trendline which doesn’t display the equation or the r2 value.

With ActiveChart.Axes(xlCategory)

.MinimumScaleIsAuto = True

.MaximumScale = iCol

.MinorUnitIsAuto = True

.MajorUnit = iCol / 5

.Crosses = xlAutomatic

.ReversePlotOrder = False

.ScaleType = xlLinear

End With

Defines the Category axes of the chart selected (scatter plot)

ActiveChart.Axes(xlValue).Select

With ActiveChart.Axes(xlValue)

.MinimumScaleIsAuto = True

.MaximumScale = 100

.MinorUnitIsAuto = True

.MajorUnitIsAuto = True

.Crosses = xlAutomatic

.ReversePlotOrder = False

.ScaleType = xlLinear

End With

Defines the Value axes of the selected scatter plot

Application.CutCopyMode = False

ActiveWindow.Visible = False

Windows(slaveFile).Activate

ActiveCell.Offset(-26, 0).Range("A1").Select

'

printRow = rowCount + 45

End If

' Application.ScreenUpdating = True

boxButtons = vbYesNo + vbDefaultButton1

response = MsgBox(prompt:="Display preview of printout?", _

Buttons:=boxButtons)

Show message box

If response = vbYes Then

With ActiveSheet.PageSetup

' .PrintTitleRows = "1:1"

.PrintTitleColumns = ""

' .PrintArea = "$1:$16384"

' MsgBox "printRow " & printRow

.PrintArea = "$1:$" & printRow

' .PrintArea = ActiveSheet.UsedRange

.LeftHeader = "&10&D" & Chr(10) & "No. of Candidates = " & _

rowCount - 2

.CenterHeader = "&10Physics and Astronomy" & Chr(10) & _

"BSc. and MSci. degrees " & exyear

.RightHeader = "&10CONFIDENTIAL" & Chr(10) & "Module " _

& moduleName

' .LeftFooter = ""

.CenterFooter = "&10Page &P of &N"

.RightFooter = "&10Module" & moduleName

.LeftMargin = Application.InchesToPoints(0.75)

' .RightMargin = Application.InchesToPoints(0.75)

' .TopMargin = Application.InchesToPoints(1)

' .BottomMargin = Application.InchesToPoints(1)

' .HeaderMargin = Application.InchesToPoints(0.5)

' .FooterMargin = Application.InchesToPoints(0.5)

' .PrintHeadings = False

.PrintGridlines = True

' .PrintNotes = False

' .PrintQuality = 360

' .CenterHorizontally = False

' .CenterVertically = False

.Orientation = xlPortrait

If printCol > 35 Then .Orientation = xlLandscape

' .Draft = False

.PaperSize = xlPaperA4

' .FirstPageNumber = xlAutomatic

' .Order = xlDownThenOver

' .BlackAndWhite = False

' .Zoom = 100

.PrintTitleRows = "$1:$1"

End With

ActiveSheet.PrintPreview

If response to message box is yes, show page setup of the usedRange and properties as specified above.

End If

Application.ScreenUpdating = True

End Sub

................
................

In order to avoid copyright disputes, this page is only a partial summary.

Google Online Preview   Download