Create an output based on cell values and a name column? Hi, This is quite a spe

Question

Create an output based on cell values and a name column?

Hi,

This is quite a specific question, for my school as a time saver.

We track pupils behaviour daily. Column A is their names and column B onwards will be a days' behaviour denoted as a G, A or R to denote Green Amber and Red.

To show this every day to the pupils someone makes a Word document and copies the names off onto an A4 sheet, with all the people in Green in the top third of the page, Yellow names in the middle and Red at the bottom.

Is there a way to get Excel to do this automatically, maybe via a Macro of some sort. It also needs to be relatively easy to change daily as to what Column gets matched to the names in Column A.

Thanks in advance and I hope this has made sense.

Explanation / Answer

Here is a macro. It will prompt you to provide the column (enter the column letter, e.g. K).

I have assumed that the first row contains headers. If not, change .Header:=xlYes to .Header:=xlNo

Sub CreateReport()
    Dim wshCurr As Worksheet
    Dim wshTemp As Worksheet
    Dim lngLastRow As Long
    Dim strColumn As String
    Dim rngColumn As Range
    Dim objWord As Object
    Dim objDoc As Object
    ' Active sheet
    Set wshCurr = ActiveSheet
    ' Last row
    lngLastRow = wshCurr.Cells(Rows.Count, 1).End(xlUp).Row
    ' Prompt for column to be copied
    strColumn = InputBox(Prompt:="Enter column")
    On Error GoTo ErrHandler
    ' Try to set range to behaviour column
    Set rngColumn = wshCurr.Range(wshCurr.Cells(1, strColumn), wshCurr.Cells(lngLastRow, strColumn))
    On Error Resume Next
    ' Get reference to Word
    Set objWord = GetObject(Class:="Word.Application")
    If objWord Is Nothing Then
        ' Word wasn't running, so start it
        Set objWord = CreateObject(Class:="Word.Application")
        If objWord Is Nothing Then
            MsgBox "Can't start Word", vbExclamation
            Exit Sub
        End If
        objWord.Visible = True
    End If
    On Error GoTo ErrHandler
    ' Create temporary sheet
    Set wshTemp = Worksheets.Add(After:=wshCurr)
    ' Copy behaviour column
    rngColumn.Copy Destination:=wshTemp.Cells(1, 2)
    ' Copy name column
    Set rngColumn = wshCurr.Range(wshCurr.Cells(1, 1), wshCurr.Cells(lngLastRow, 1))
    rngColumn.Copy Destination:=wshTemp.Cells(1, 1)
    ' Sort on the behaviour column
    With wshTemp.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wshTemp.Cells(1, 2), CustomOrder:="G,A,R"
        .SetRange wshTemp.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    ' Adjust column widths
    wshTemp.UsedRange.EntireColumn.AutoFit
    ' Create document
    Set objDoc = objWord.documents.Add
    ' Copy/paste range
    wshTemp.UsedRange.Copy
    objDoc.Content.Paste
    ' Delete temporary sheet
    Application.DisplayAlerts = False
    wshTemp.Delete
    Application.DisplayAlerts = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
End Sub

Related Questions

Navigate

• Browse (All)
• Browse C
• Subjects

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.