' 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.
To fulfill the demand for quickly locating and searching documents.
It is intelligent file search solution for home and business.
Related searches
- general loan payment calculator
- the general equation for photosynthesis
- general trivia questions and answers
- general surgery salary
- what do general surgeons do
- general surgeons in my area
- 100 general knowledge questions
- top general knowledge questions
- list of general surgery procedures
- average general surgeon salary 2018
- general surgeon compensation
- general surgery average salary