Expert Coders: Is this possible or conceivable? Coding votes into binary

[dguenther]

Excel 2007 on Windows 7

Hi,
I don't know if what I am about to ask is even possible. I kind of think not. But, Mr Excel people have done amazing things for me so far.

Here is the situation:

I have hundreds of files like this one:
https://my.syncplicity.com/share/bbxisyzjvs/WV_macro_applied.xlsm

The first sheet is a bunch of legal case information, spread out over hundreds of rows in column A.

The second sheet is always called "Report". It has taken the information from the first sheet and nicely put every case into its own row, separating data into it proper column. Super kudos to Rick Rothstein and Sektor for those codes.

One further transformation is necessary. I have resigned myself to thinking I will have to do this by hand, but maybe someone can surprise me. The last column of the second sheet contains the voting records of the judges on the case. Those need to be coded into 1,0, and 9.

A 1 means that the judge voted in the majority (or concurred)in the case.
A 0 means that the judge voted in the minority (dissented) in the case.
A 9 means that the judge did not vote or did not participate.

In a separate sheet, needs to be the following:

The list of docket numbers (always going to be column B from the "report" sheet) transposed to go on row A of the new "Binary" sheet.

Then magic occurs. The judges’ votes (always in column E of the Report sheet) in each case need to be put into the 0,1,9 category. There can be no other information in the "binary" sheet (per the requirements of the statistical program later used to process this stuff).

Problem is, the formatting is not beautiful. And they vary state by state. Here are three example files where I translated by hand, the judges’ votes from the “Report” sheet to the “Binary” sheet I created. (On two of them, I only did the first 5)

https://my.syncplicity.com/share/6xwkn0vp31/FL_cases_macro_applied.xlsm
https://my.syncplicity.com/share/gbe5eiem8e/VT_cases_macro_applied.xlsm
https://my.syncplicity.com/share/bbxisyzjvs/WV_macro_applied.xlsm

They can look like anything from the typical (I would venture to guess 75% of them look like this):

Adkins, C.J., and Roberts, Overton and Hatchett, JJ., concur. Boyd, J., dissents....

{So, obviously Adkins, Roberts, Overton, and Hatchett would all get a 1. Boyd would get a 0.

- to a little more complex

England, Justice. Boyd, Overton and Sundberg, JJ., concur. Adkins, C.J., dissents with an opinion, with which Chappell, Circuit Judge, concurs. ...


{Here, Boyd, Overton, and Sundberg get 1s, while Adkins and Chappell get 0s.}

- to really complicated

Adkins, Chief Justice. McCain, J., and McCrary and Lee, Circuit Court Judges, concur. Overton, J., concurring in part and dissenting in part with opinion with which Drew (Retired), J., concurs.

{Here, Adkins, McCain, McCrary and Lee get 1s. Overton and Drew get 0s. Even a partial dissent is to be coded as dissent.}

=====

So from those example files you can see what an end product needs to be. 1,0, and 9s. Deceivingly simple sounding.

I will update this post with my thoughts and experiences as I try to apply a good solution to save me weeks, possibly months! of time.

Even anything that can automate or help part of this problem would be extremely appreciated. Even just thoughts about how to go about approaching it in the most efficient way would help.


Questions, thoughts, encouragement:
Reply to this post and/or
dsguenth [at] wustl.edu

 

[al_b_cnu]

Hi Danny,

A macro 'GetNames' to help determine Judge names (note this code also includes the 'VotingResult' function):

Option Explicit
Dim miMinLength As Long
Dim mobjIgnoreWords As Object
Dim mrSourceRange As Range
Dim mrTargetRange As Range

Sub GetNames()
Dim iCol As Integer
Dim lPtr As Long, lPtr1 As Long
Dim objCandidates As Object
Dim rCur As Range
Dim sCurVotingRecord As String, saVRSplit() As String, sCurChar As String, sCurCandidate As String
Dim vaNameEntry As Variant, vaItems() As Variant, vCurKey As Variant

'-- Get parameters, exit if errors found --
If GetParameters = True Then Exit Sub

'-- Initialise Candidates dictionary --
Set objCandidates = Nothing
Set objCandidates = CreateObject("Scripting.Dictionary")

For Each rCur In mrSourceRange
    sCurVotingRecord = CStr(rCur.Value)
    For lPtr = 1 To Len(sCurVotingRecord)
        sCurChar = Mid$(sCurVotingRecord, lPtr, 1)
        If LCase$(sCurChar) = UCase$(sCurChar) Then Mid$(sCurVotingRecord, lPtr, 1) = " "
    Next lPtr
    sCurVotingRecord = WorksheetFunction.Trim(sCurVotingRecord)
    If sCurVotingRecord <> "" Then
        saVRSplit = Split(sCurVotingRecord, " ")
        For lPtr = 0 To UBound(saVRSplit)
            sCurCandidate = LCase$(saVRSplit(lPtr))
            If Len(sCurCandidate) >= miMinLength Then
                If mobjIgnoreWords.exists(sCurCandidate) = False Then
                    ReDim vaNameEntry(1 To 2)
                    If objCandidates.exists(sCurCandidate) Then
                        vaNameEntry = objCandidates.Item(sCurCandidate)
                        objCandidates.Remove key:=sCurCandidate
                    Else
                        vaNameEntry(1) = saVRSplit(lPtr)
                        vaNameEntry(2) = 0
                    End If
                    vaNameEntry(2) = Val(vaNameEntry(2)) + 1
                    objCandidates.Add key:=sCurCandidate, Item:=vaNameEntry
                End If
            End If
        Next lPtr
    End If
Next rCur


'-- Extract candidate names plus scores into array --
ReDim vaItems(1 To objCandidates.Count + 1, 1 To 2)
lPtr = 1
vaItems(1, 1) = "Candidate"
vaItems(1, 2) = "Score"
For Each vCurKey In objCandidates.keys
    lPtr = lPtr + 1
    vaNameEntry = objCandidates.Item(vCurKey)
    vaItems(lPtr, 1) = vaNameEntry(1)
    vaItems(lPtr, 2) = vaNameEntry(2)
Next vCurKey

'-- Bubblesort the array into descending frequency --
ReDim vaNameEntry(1 To 2)
For lPtr = 2 To UBound(vaItems, 1) - 1
    For lPtr1 = lPtr + 1 To UBound(vaItems, 1)
        If vaItems(lPtr, 2) < vaItems(lPtr1, 2) Then
            For iCol = 1 To 2
                vaNameEntry(iCol) = vaItems(lPtr, iCol)
                vaItems(lPtr, iCol) = vaItems(lPtr1, iCol)
                vaItems(lPtr1, iCol) = vaNameEntry(iCol)
            Next iCol
        End If
    Next lPtr1
Next lPtr

mrTargetRange.Resize(UBound(vaItems, 1), UBound(vaItems, 2)).Value = vaItems

mobjIgnoreWords.RemoveAll
Set mobjIgnoreWords = Nothing

objCandidates.RemoveAll
Set objCandidates = Nothing

End Sub

Private Function GetParameters() As Boolean
Dim bErrorFound As Boolean
Dim iPtr As Integer
Dim rCur As Range
Dim sCurKeyword As String, sCurValue As String, saSplit() As String

With Sheets("Parameters")
    For Each rCur In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        sCurKeyword = UCase$(Replace((CStr(rCur.Value)), " ", ""))
        sCurValue = CStr(rCur.Offset(, 1))
        Select Case sCurKeyword
        Case "IGNOREWORDS"
            '-- Store words to be ignored in a dictionary object --
            Set mobjIgnoreWords = Nothing
            If sCurValue <> "" Then
                Set mobjIgnoreWords = CreateObject("Scripting.Dictionary")
                saSplit = Split(LCase$(Replace(sCurValue, " ", "")), ",")
                For iPtr = 0 To UBound(saSplit)
                    On Error Resume Next
                    mobjIgnoreWords.Add key:=saSplit(iPtr), Item:=saSplit(iPtr)
                    On Error GoTo 0
                Next iPtr
            End If
        Case "MINIMUMNAMELENGTH"
            miMinLength = Val(rCur.Offset(, 1))
        Case "SOURCEDATA"
            saSplit = Split(sCurValue, "!")
            Set mrSourceRange = Nothing
            On Error Resume Next
            Set mrSourceRange = Sheets(saSplit(0)).Range(saSplit(1))
            On Error GoTo 0
            If mrSourceRange Is Nothing Then
                bErrorFound = True
                MsgBox "'Source Data' parameter incorrect"
            End If
        Case "RESULTSSTARTCELL"
            saSplit = Split(sCurValue, "!")
            Set mrTargetRange = Nothing
            On Error Resume Next
            Set mrTargetRange = Sheets(saSplit(0)).Range(saSplit(1))
            On Error GoTo 0
            If mrTargetRange Is Nothing Then
                bErrorFound = True
                MsgBox "'Results Start Cell' parameter incorrect"
            End If
        End Select
    Next rCur
End With

GetParameters = bErrorFound
End Function
Function VotingResult(ByVal Name As String, ByVal VotingRecord As String) As Variant
Dim iPtr As Integer, iNamePtr  As Integer, iVotePtr As Integer
Dim sChar As String, sVotingRecord As String, saVotingRecord() As String

Name = Trim$(LCase$(Name))

'-- convert all non-alphabetics to spaces --
For iPtr = 1 To Len(VotingRecord)
    sChar = LCase$(Mid$(VotingRecord, iPtr, 1))
    If sChar = UCase$(sChar) Then sChar = " "
    sVotingRecord = sVotingRecord & sChar
Next iPtr

sVotingRecord = WorksheetFunction.Trim(sVotingRecord)
sVotingRecord = Replace(sVotingRecord, "concurring in part", "dissent")
VotingResult = 9
If Len(Trim$(sVotingRecord)) <> 0 Then
    saVotingRecord = Split(sVotingRecord, " ")
    For iPtr = 0 To UBound(saVotingRecord)
         If saVotingRecord(iPtr) = Name Then
            For iNamePtr = iPtr + 1 To UBound(saVotingRecord)
                Select Case saVotingRecord(iNamePtr)
                Case "concur", "concurs", "concurring"
                    VotingResult = 0
                    Exit Function
                Case "dissent", "dissents", "dissenting"
                    VotingResult = 1
                    Exit Function
                End Select
            Next iNamePtr
         End If
    Next iPtr
End If
End Function

You need a sheet named 'Parameters:
<b>Excel 2003</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>A</th><th>B</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style="font-weight: bold;;">Keyword</td><td style="font-weight: bold;;">Value</td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style=";">Ignore Words</td><td style=";">and, Justice, circuit, Judge, Judges,with, which, retired, in, part, concur, concurs, dissent, dissents,opinion, concurring, Dissenting</td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style=";">Minimum Name Length</td><td style=";">3</td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style=";">Source Data</td><td style=";">Sheet1!A2:A4</td></tr><tr ><td style="color: #161120;text-align: center;">5</td><td style=";">Results start Cell</td><td style=";">Sheet3!A1</td></tr></tbody></table><p style="width:6em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #A6AAB6;border-top:none;text-align: center;background-color: #E0E0F0;color: #161120">Parameters</p><br /><br />

Source Data (as defined in Parameters):
<b>Excel 2003</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>A</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style="font-weight: bold;;">Voting Records</td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style=";">Adkins, C.J., and Roberts, Overton and Hatchett, JJ., concur. Boyd, J., dissents</td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style=";">England, Justice. Boyd, Overton and Sundberg, JJ., concur. Adkins, C.J., dissents with an opinion, with which Chappell, Circuit Judge, concurs.</td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style=";">Adkins, Chief Justice. McCain, J., and McCrary and Lee, Circuit Court Judges, concur. Overton, J., concurring in part and dissenting in part with opinion with which Drew (Retired), J., concurs.</td></tr></tbody></table><p style="width:3.6em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #A6AAB6;border-top:none;text-align: center;background-color: #E0E0F0;color: #161120">Sheet1</p><br /><br />

Results (as defined by Parameters):
<b>Excel 2003</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>A</th><th>B</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style=";">Candidate</td><td style=";">Score</td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style=";">Adkins</td><td style="text-align: right;;">3</td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style=";">Overton</td><td style="text-align: right;;">3</td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style=";">Boyd</td><td style="text-align: right;;">2</td></tr><tr ><td style="color: #161120;text-align: center;">5</td><td style=";">Roberts</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">6</td><td style=";">Sundberg</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">7</td><td style=";">Chappell</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">8</td><td style=";">Hatchett</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">9</td><td style=";">Chief</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">10</td><td style=";">McCain</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">11</td><td style=";">McCrary</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">12</td><td style=";">Lee</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">13</td><td style=";">Court</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">14</td><td style=";">England</td><td style="text-align: right;;">1</td></tr><tr ><td style="color: #161120;text-align: center;">15</td><td style=";">Drew</td><td style="text-align: right;;">1</td></tr></tbody></table><p style="width:3.6em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #A6AAB6;border-top:none;text-align: center;background-color: #E0E0F0;color: #161120">Sheet3</p><br /><br />

 

[dguenther]

Hi,

I'm looking over the getjudges code right now. One thing I am finding is it is hard to come up with every possible exclusion. One thing that would really help is if the code could exclude any lowercase words. All judges names are upper case.

 

[al_b_cnu]

Hi Danny,

Try this version which has an additional parameter 'Allow Cases', which can have one or more of the values 'upper', 'First Upper;, 'any', lower' (seperated by comma)

<b>Excel 2003</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>A</th><th>B</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style="font-weight: bold;;">Keyword</td><td style="font-weight: bold;;">Value</td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style=";">Ignore Words</td><td style=";">and, Justice, circuit, Judge, Judges,withxx, which, retired, in, part, xxconcur, concurs, dissent, dissents,opinion, concurring, Dissenting</td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style=";">Minimum Name Length</td><td style="text-align: right;;">3</td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style=";">Source Data</td><td style=";">Sheet1!A2:A5</td></tr><tr ><td style="color: #161120;text-align: center;">5</td><td style=";">Results start Cell</td><td style=";">Sheet3!A1</td></tr><tr ><td style="color: #161120;text-align: center;">6</td><td style=";">Allow Cases</td><td style=";">upper</td></tr></tbody></table><p style="width:6em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #A6AAB6;border-top:none;text-align: center;background-color: #E0E0F0;color: #161120">Parameters</p><br /><br />

Voting Records
Adkins, C.J., and Roberts, Overton and Hatchett, JJ., concur. Boyd, J., dissents
England, Justice. Boyd, Overton and Sundberg, JJ., concur. Adkins, C.J., dissents with an opinion, with which Chappell, Circuit Judge, concurs.
Adkins, Chief Justice. McCain, J., and McCrary and Lee, Circuit Court Judges, concur. Overton, J., concurring in part and dissenting in part with opinion with which Drew (Retired), J., concurs.
England, Justice. BOYD, Overton and Sundberg, JJ., concur. ADKINS, C.J., dissents with an opinion, with which Chappell, Circuit Judge, concurs.


Candidate Score
BOYD 1
ADKINS 1

Option Explicit
Dim miMinLength As Long
Dim mobjIgnoreWords As Object
Dim mrSourceRange As Range
Dim mrTargetRange As Range
Dim msaAllowCases() As String

Sub GetNames()
Dim bValid As Boolean
Dim iCol As Integer
Dim lPtr As Long, lPtr1 As Long
Dim iCasePtr As Integer
Dim objCandidates As Object
Dim rCur As Range
Dim sCurVotingRecord As String, saVRSplit() As String, sCurChar As String, sCurCandidate As String
Dim vaNameEntry As Variant, vaItems() As Variant, vCurKey As Variant

'-- Get parameters, exit if errors found --
If GetParameters = True Then Exit Sub

'-- Initialise Candidates dictionary --
Set objCandidates = Nothing
Set objCandidates = CreateObject("Scripting.Dictionary")

For Each rCur In mrSourceRange
    sCurVotingRecord = CStr(rCur.Value)
    For lPtr = 1 To Len(sCurVotingRecord)
        sCurChar = Mid$(sCurVotingRecord, lPtr, 1)
        If LCase$(sCurChar) = UCase$(sCurChar) Then Mid$(sCurVotingRecord, lPtr, 1) = " "
    Next lPtr
    sCurVotingRecord = WorksheetFunction.Trim(sCurVotingRecord)
    If sCurVotingRecord <> "" Then
        saVRSplit = Split(sCurVotingRecord, " ")
        For lPtr = 0 To UBound(saVRSplit)
            sCurCandidate = LCase$(saVRSplit(lPtr))
            If Len(sCurCandidate) >= miMinLength Then
                If mobjIgnoreWords.exists(sCurCandidate) = False Then
                    bValid = False
                    For iCasePtr = 0 To UBound(msaAllowCases)
                        Select Case msaAllowCases(iCasePtr)
                        Case "any"
                            bValid = True
                            Exit For
                        Case "firstupper"
                            If Left$(saVRSplit(lPtr), 1) = UCase$(Left$(saVRSplit(lPtr), 1)) Then
                                bValid = True
                                Exit For
                            End If
                        Case "upper"
                            If UCase$(sCurCandidate) = saVRSplit(lPtr) Then
                                bValid = True
                                Exit For
                            End If
                        Case "lower"
                            If sCurCandidate = saVRSplit(lPtr) Then
                                bValid = True
                                Exit For
                            End If
                        End Select
                    Next iCasePtr
                                        
                    If bValid Then
                        ReDim vaNameEntry(1 To 2)
                        If objCandidates.exists(sCurCandidate) Then
                            vaNameEntry = objCandidates.Item(sCurCandidate)
                            objCandidates.Remove Key:=sCurCandidate
                        Else
                            vaNameEntry(1) = saVRSplit(lPtr)
                            vaNameEntry(2) = 0
                        End If
                        vaNameEntry(2) = Val(vaNameEntry(2)) + 1
                        objCandidates.Add Key:=sCurCandidate, Item:=vaNameEntry
                    End If
                End If
            End If
        Next lPtr
    End If
Next rCur

'-- Extract candidate names plus scores into array --
ReDim vaItems(1 To objCandidates.Count + 1, 1 To 2)
lPtr = 1
vaItems(1, 1) = "Candidate"
vaItems(1, 2) = "Score"
For Each vCurKey In objCandidates.keys
    lPtr = lPtr + 1
    vaNameEntry = objCandidates.Item(vCurKey)
    vaItems(lPtr, 1) = vaNameEntry(1)
    vaItems(lPtr, 2) = vaNameEntry(2)
Next vCurKey

'-- Bubblesort the array into descending frequency --
ReDim vaNameEntry(1 To 2)
For lPtr = 2 To UBound(vaItems, 1) - 1
    For lPtr1 = lPtr + 1 To UBound(vaItems, 1)
        If vaItems(lPtr, 2) < vaItems(lPtr1, 2) Then
            For iCol = 1 To 2
                vaNameEntry(iCol) = vaItems(lPtr, iCol)
                vaItems(lPtr, iCol) = vaItems(lPtr1, iCol)
                vaItems(lPtr1, iCol) = vaNameEntry(iCol)
            Next iCol
        End If
    Next lPtr1
Next lPtr

mrTargetRange.Resize(UBound(vaItems, 1), UBound(vaItems, 2)).Value = vaItems

mobjIgnoreWords.RemoveAll
Set mobjIgnoreWords = Nothing

objCandidates.RemoveAll
Set objCandidates = Nothing

End Sub

Private Function GetParameters() As Boolean
Dim bErrorFound As Boolean
Dim iPtr As Integer
Dim rCur As Range
Dim sCurKeyword As String, sCurValue As String, saSplit() As String

With Sheets("Parameters")
    For Each rCur In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        sCurKeyword = UCase$(Replace((CStr(rCur.Value)), " ", ""))
        sCurValue = CStr(rCur.Offset(, 1))
        Select Case sCurKeyword
        Case "IGNOREWORDS"
            '-- Store words to be ignored in a dictionary object --
            Set mobjIgnoreWords = Nothing
            If sCurValue <> "" Then
                Set mobjIgnoreWords = CreateObject("Scripting.Dictionary")
                saSplit = Split(LCase$(Replace(sCurValue, " ", "")), ",")
                For iPtr = 0 To UBound(saSplit)
                    On Error Resume Next
                    mobjIgnoreWords.Add Key:=saSplit(iPtr), Item:=saSplit(iPtr)
                    On Error GoTo 0
                Next iPtr
            End If
        Case "MINIMUMNAMELENGTH"
            miMinLength = Val(rCur.Offset(, 1))
        Case "SOURCEDATA"
            saSplit = Split(sCurValue, "!")
            Set mrSourceRange = Nothing
            On Error Resume Next
            Set mrSourceRange = Sheets(saSplit(0)).Range(saSplit(1))
            On Error GoTo 0
            If mrSourceRange Is Nothing Then
                bErrorFound = True
                MsgBox "'Source Data' parameter incorrect"
            End If
        Case "RESULTSSTARTCELL"
            saSplit = Split(sCurValue, "!")
            Set mrTargetRange = Nothing
            On Error Resume Next
            Set mrTargetRange = Sheets(saSplit(0)).Range(saSplit(1))
            On Error GoTo 0
            If mrTargetRange Is Nothing Then
                bErrorFound = True
                MsgBox "'Results Start Cell' parameter incorrect"
            End If
            Case "ALLOWCASES"
                msaAllowCases = Split(LCase$(Replace(sCurValue, " ", "")), ",")
        End Select
    Next rCur
End With

GetParameters = bErrorFound
End Function
Function VotingResult(ByVal Name As String, ByVal VotingRecord As String) As Variant
Dim iPtr As Integer, iNamePtr  As Integer, iVotePtr As Integer
Dim sChar As String, sVotingRecord As String, saVotingRecord() As String

Name = Trim$(LCase$(Name))

'-- convert all non-alphabetics to spaces --
For iPtr = 1 To Len(VotingRecord)
    sChar = LCase$(Mid$(VotingRecord, iPtr, 1))
    If sChar = UCase$(sChar) Then sChar = " "
    sVotingRecord = sVotingRecord & sChar
Next iPtr

sVotingRecord = WorksheetFunction.Trim(sVotingRecord)
sVotingRecord = Replace(sVotingRecord, "concurring in part", "dissent")
VotingResult = 9
If Len(Trim$(sVotingRecord)) <> 0 Then
    saVotingRecord = Split(sVotingRecord, " ")
    For iPtr = 0 To UBound(saVotingRecord)
         If saVotingRecord(iPtr) = Name Then
            For iNamePtr = iPtr + 1 To UBound(saVotingRecord)
                Select Case saVotingRecord(iNamePtr)
                Case "concur", "concurs", "concurring"
                    VotingResult = 0
                    Exit Function
                Case "dissent", "dissents", "dissenting"
                    VotingResult = 1
                    Exit Function
                End Select
            Next iNamePtr
         End If
    Next iPtr
End If
End Function

 

[dguenther]

al_b_cnu,

You rock. I am going to look through and see why sometimes though it just returns

Candidate Score
Candidate Score

instead of judges' names.

I did change source data to

Source Data Sheet1!A2:A500

so as to accommodate longer cases.


This really ugly example returned such a result:

"Heard, considered, and decided by the court en banc. Wahl, Justice. Yetka, Justice (concurring in part and dissenting in part). Peterson, J., took no part in the consideration or decision of this case. ..."


-Danny

 

[al_b_cnu]

Hi Danny,
Change 'upper' to 'first upper'
Also clear Sheet3 before running

 

[dguenther]

Perfect. I realize that it was I who was screwing up sheet 3 by already having words in there. doh

Anyways, I am going out of town in a few hours for a few days. I have budgeted most of next week to come up with the heuristics of how the syntax works in various cases (for the binary coding part).

For instance I have everything from

-
Adkins, C.J., and Roberts, Overton and Hatchett, JJ., concur. Boyd, J., dissents
-
-
Denecke, Chief Justice, and Peterson and Tanzer, Justices. Lent and Linde, Justices, filed concurring opinions. Howell, Justice, filed a dissenting opinion
-
-
... [***1] C. J., * and O'Brien, Roberts, Manderino, Nix and Larsen, JJ. Manderino, J., did not participate in the decision of this case. Roberts, J., filed a dissenting opinion....
-
-
En Banc. Higgins, J. Donnelly, Seiler, Welliver and Morgan, JJ., concur. Bardgett, C.J., dissents in separate dissenting opinion filed. Rendlen, J., dissents and concurs in separate dissenting opinion of Bardgett, C.J. ...
-
-
Chief Justice Neely concludes that appellant met his burden of proving a change of custody was justified, and on this point dissents from this opinion and would reverse the trial court. ...
-
-
WM. H. D. Fones, J., wrote the opinion. Concur: Brock, C.J., Henry, J. Cooper, Harbison, JJ. dissent (see separate opinion). Mr. Justice Harbison concurs in this opinion. ...
-
-
... [***2] C. J., and Smith, Digges, Eldridge, Cole, Davidson and Rodowsky, JJ. Digges, J., delivered the opinion of the Court. Murphy, C. J., and Rodowsky, J., dissent. Murphy, C. J., filed a dissenting opinion at page 642 infra, in which Rodowsky, J., concurs. ...
-
-
... [**3] Justice, Rabinowitz, Burke, Compton and Moore, Justices. Moore, Justice, joined by Matthews, Chief Justice, and in part by Burke, Justice. Burke, Justice, concurring. Rabinowitz, Justice, dissenting, joined by Compton, Justice. Compton, Justice, dissenting....
-
-

Cotter, C. J., Loiselle, Bogdanski, Parskey and Sidor, Js. In this opinion Loiselle and Bogdanski, Js., concurred. Cotter, C. J. dissenting. Sidor, J. dissenting....
-
-


Just to throw out a few types. But, most instances are very close. and it is generally consistent within a state across years. so one macro for a state should process all 50 years of it. And even if I had to write out 20 heuristics, it would hardly come close to the time of hand coding 1,000,000+ 1s, 9s, and 0s.


Appreciate you help. You've given me hope on what I thought was an impossible task.

-Danny

 

[al_b_cnu]

Hi Danny,

Looking at your examples, I think this may get us a bit nearer our goal.
I have changed the macro & function code to:
1) allow an apostrophe (as in "O'Brien")
2) Recognise 'not participate' and 'took no part', which will return a 9
3) scan backwards thru the voting record for the name then scan forwards for the concur / dissent / not participate and return appropriate value. This caters for your last example.

Since you mentioned a million records, perhaps the function should be replaced with a macro which will take less time (but still take ages), but let's get the function working first.

Here's the new code:

Option Explicit
Dim miMinLength As Long
Dim mobjIgnoreWords As Object
Dim mrSourceRange As Range
Dim mrTargetRange As Range
Dim msaAllowCases() As String

Sub GetNames()
Dim bValid As Boolean
Dim iCol As Integer
Dim lPtr As Long, lPtr1 As Long
Dim iCasePtr As Integer
Dim objCandidates As Object
Dim rCur As Range
Dim sCurVotingRecord As String, saVRSplit() As String, sCurChar As String, sCurCandidate As String
Dim vaNameEntry As Variant, vaItems() As Variant, vCurKey As Variant

'-- Get parameters, exit if errors found --
If GetParameters = True Then Exit Sub

'-- Initialise Candidates dictionary --
Set objCandidates = Nothing
Set objCandidates = CreateObject("Scripting.Dictionary")

For Each rCur In mrSourceRange
    sCurVotingRecord = CStr(rCur.Value)
    For lPtr = 1 To Len(sCurVotingRecord)
        sCurChar = Mid$(sCurVotingRecord, lPtr, 1)
        If LCase$(sCurChar) = UCase$(sCurChar) And sCurChar <> "'" Then Mid$(sCurVotingRecord, lPtr, 1) = " "
    Next lPtr
    sCurVotingRecord = WorksheetFunction.Trim(sCurVotingRecord)
    If sCurVotingRecord <> "" Then
        saVRSplit = Split(sCurVotingRecord, " ")
        For lPtr = 0 To UBound(saVRSplit)
            sCurCandidate = LCase$(saVRSplit(lPtr))
            If Len(sCurCandidate) >= miMinLength Then
                If mobjIgnoreWords.exists(sCurCandidate) = False Then
                    bValid = False
                    For iCasePtr = 0 To UBound(msaAllowCases)
                        Select Case msaAllowCases(iCasePtr)
                        Case "any"
                            bValid = True
                            Exit For
                        Case "firstupper"
                            If Left$(saVRSplit(lPtr), 1) = UCase$(Left$(saVRSplit(lPtr), 1)) Then
                                bValid = True
                                Exit For
                            End If
                        Case "upper"
                            If UCase$(sCurCandidate) = saVRSplit(lPtr) Then
                                bValid = True
                                Exit For
                            End If
                        Case "lower"
                            If sCurCandidate = saVRSplit(lPtr) Then
                                bValid = True
                                Exit For
                            End If
                        End Select
                    Next iCasePtr
                                        
                    If bValid Then
                        ReDim vaNameEntry(1 To 2)
                        If objCandidates.exists(sCurCandidate) Then
                            vaNameEntry = objCandidates.Item(sCurCandidate)
                            objCandidates.Remove Key:=sCurCandidate
                        Else
                            vaNameEntry(1) = saVRSplit(lPtr)
                            vaNameEntry(2) = 0
                        End If
                        vaNameEntry(2) = Val(vaNameEntry(2)) + 1
                        objCandidates.Add Key:=sCurCandidate, Item:=vaNameEntry
                    End If
                End If
            End If
        Next lPtr
    End If
Next rCur

'-- Extract candidate names plus scores into array --
ReDim vaItems(1 To objCandidates.Count + 1, 1 To 2)
lPtr = 1
vaItems(1, 1) = "Candidate"
vaItems(1, 2) = "Score"
For Each vCurKey In objCandidates.keys
    lPtr = lPtr + 1
    vaNameEntry = objCandidates.Item(vCurKey)
    vaItems(lPtr, 1) = vaNameEntry(1)
    vaItems(lPtr, 2) = vaNameEntry(2)
Next vCurKey

'-- Bubblesort the array into descending frequency --
ReDim vaNameEntry(1 To 2)
For lPtr = 2 To UBound(vaItems, 1) - 1
    For lPtr1 = lPtr + 1 To UBound(vaItems, 1)
        If vaItems(lPtr, 2) < vaItems(lPtr1, 2) Then
            For iCol = 1 To 2
                vaNameEntry(iCol) = vaItems(lPtr, iCol)
                vaItems(lPtr, iCol) = vaItems(lPtr1, iCol)
                vaItems(lPtr1, iCol) = vaNameEntry(iCol)
            Next iCol
        End If
    Next lPtr1
Next lPtr

mrTargetRange.Resize(UBound(vaItems, 1), UBound(vaItems, 2)).Value = vaItems

mobjIgnoreWords.RemoveAll
Set mobjIgnoreWords = Nothing

objCandidates.RemoveAll
Set objCandidates = Nothing

End Sub

Private Function GetParameters() As Boolean
Dim bErrorFound As Boolean
Dim iPtr As Integer
Dim rCur As Range
Dim sCurKeyword As String, sCurValue As String, saSplit() As String

With Sheets("Parameters")
    For Each rCur In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        sCurKeyword = UCase$(Replace((CStr(rCur.Value)), " ", ""))
        sCurValue = CStr(rCur.Offset(, 1))
        Select Case sCurKeyword
        Case "IGNOREWORDS"
            '-- Store words to be ignored in a dictionary object --
            Set mobjIgnoreWords = Nothing
            If sCurValue <> "" Then
                Set mobjIgnoreWords = CreateObject("Scripting.Dictionary")
                saSplit = Split(LCase$(Replace(sCurValue, " ", "")), ",")
                For iPtr = 0 To UBound(saSplit)
                    On Error Resume Next
                    mobjIgnoreWords.Add Key:=saSplit(iPtr), Item:=saSplit(iPtr)
                    On Error GoTo 0
                Next iPtr
            End If
        Case "MINIMUMNAMELENGTH"
            miMinLength = Val(rCur.Offset(, 1))
        Case "SOURCEDATA"
            saSplit = Split(sCurValue, "!")
            Set mrSourceRange = Nothing
            On Error Resume Next
            Set mrSourceRange = Sheets(saSplit(0)).Range(saSplit(1))
            On Error GoTo 0
            If mrSourceRange Is Nothing Then
                bErrorFound = True
                MsgBox "'Source Data' parameter incorrect"
            End If
        Case "RESULTSSTARTCELL"
            saSplit = Split(sCurValue, "!")
            Set mrTargetRange = Nothing
            On Error Resume Next
            Set mrTargetRange = Sheets(saSplit(0)).Range(saSplit(1))
            On Error GoTo 0
            If mrTargetRange Is Nothing Then
                bErrorFound = True
                MsgBox "'Results Start Cell' parameter incorrect"
            End If
            Case "ALLOWCASES"
                msaAllowCases = Split(LCase$(Replace(sCurValue, " ", "")), ",")
        End Select
    Next rCur
End With

GetParameters = bErrorFound
End Function
Function VotingResult(ByVal Name As String, ByVal VotingRecord As String) As Variant
Dim iPtr As Integer, iNamePtr  As Integer, iVotePtr As Integer
Dim sChar As String, sVotingRecord As String, saVotingRecord() As String

Name = Trim$(LCase$(Name))

'-- convert all non-alphabetics to spaces --
For iPtr = 1 To Len(VotingRecord)
    sChar = LCase$(Mid$(VotingRecord, iPtr, 1))
    If sChar <> "'" And sChar = UCase$(sChar) Then sChar = " "
    sVotingRecord = sVotingRecord & sChar
Next iPtr

sVotingRecord = WorksheetFunction.Trim(sVotingRecord)
sVotingRecord = Replace(sVotingRecord, "concurring in part", "dissent")
sVotingRecord = Replace(sVotingRecord, "not participate", "notparticipate")
sVotingRecord = Replace(sVotingRecord, "took no part", "notparticipate")

VotingResult = 9
If Len(Trim$(sVotingRecord)) <> 0 Then
    saVotingRecord = Split(sVotingRecord, " ")
    For iPtr = UBound(saVotingRecord) To 0 Step -1
         If saVotingRecord(iPtr) = Name Then
            For iNamePtr = iPtr + 1 To UBound(saVotingRecord)
                Select Case saVotingRecord(iNamePtr)
                Case "concur", "concurs", "concurring", "concurred"
                    VotingResult = 0
                    Exit Function
                Case "dissent", "dissents", "dissenting", "dissented"
                    VotingResult = 1
                    Exit Function
                Case "notparticipate"
                    VotingResult = 9
                    Exit Function
                End Select
            Next iNamePtr
         End If
    Next iPtr
End If
End Function

I have a final 'Spanner in the works' - what if there is more than one judges with the same surname?

 

[dguenther]

Hi,

So, there are 2,500 files. I estimate each one would have between <10 to maybe 100 cases with an average of about 25 though, then an average of 6 justices per case maybe so somewhere between 600,000 and 1 million 1,0,9s. It will be interesting to see the final count.

Anyways, I do anticipate finding some really fast computer on my campus to run the various macros on. But, I expect it to take a long time which is fine.

As far as various problematic cases go, it would seem to be useful if the program could recognize there is a high likelihood that it is confused and mark that one for review by a human.

Judges with the same name is one example where it would be really difficult to tell the program how to handle them. Let me think on that. Probably need to be hand coded.

A couple of thoughts:
If the judge wrote the opinion, he's in the majority.


I'll look at more cases.

 

[al_b_cnu]

Hi Danny,

ok, The VotingRecord function has now been changed to work as follows:
Store all 'Words' into an array. a Word is defined as a contiguous string of alphabetic characters, The array is then scanned from the last word back, looking for the required Judge name. When found, it scans forward for 'dissent / concur / took no part strings (and aliases). no decision is found, an 'Unsure' marker is set, and it resumes scanning backwards from where it left off.

The code will return
0 for concur
1 for Disent
9 for took no part
10 for unsafe concur
11 for unsafe dissent
19 for unsafe non-participation.

I suspect that it still needs 'Tweaking' (or even re-writing)

I have also written the supporting macros.
The system is designed to work as follows:
1) You will place the input files into a folder
2) run the 'Get Judge Names' macro which will create a list of Judge names in sheet 'Binary' in descending frequency. Note that Cell B2 in Parameters has automatically been updated.
3) You edit the list & weed out any 'chaff', & sort into alphabetic sequence
4) Run the GetVotingResults' macro to read the files in the folder & populate the Binary sheet. If we run out of columns, it will automatically create a new one.

Setup:
=====

1) Create a workbook with a sheet named 'Parameters' and a sheet named 'Binary'
2) Set the Parameters sheet to look like this:
<b>Excel 2003</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /><col /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>A</th><th>B</th><th>C</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style="font-weight: bold;;">Keyword</td><td style="font-weight: bold;;">Value</td><td style="font-weight: bold;;">Comment</td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style=";">Folder</td><td style=";"></td><td style=";">Leave this blank - the code will prompt for the input folder & auto-populate it</td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style=";">File filter</td><td style=";">*.xls*</td><td style=";">file Filter</td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style=";">Source Sheet</td><td style=";">Report</td><td style=";">Sheet name containing Voting Records & Case Numbers</td></tr><tr ><td style="color: #161120;text-align: center;">5</td><td style=";">Voting Record Column</td><td style=";">E</td><td style="text-align: right;;"></td></tr><tr ><td style="color: #161120;text-align: center;">6</td><td style=";">Case Number Column</td><td style=";">B</td><td style="text-align: right;;"></td></tr><tr ><td style="color: #161120;text-align: center;">7</td><td style=";">Noise Words</td><td style=";">and, Justice, Justices, circuit, Judge, Judges,with, which, retired, in, part, concur, concurs, dissent, dissents,opinion, concurring, Dissenting, trial, court, per, curiam, the, this, acting</td><td style=";">Words to be ignored in 'Get Judge Names' macro</td></tr><tr ><td style="color: #161120;text-align: center;">8</td><td style=";">Minimum Name Length</td><td style=";">3</td><td style=";">min length for Judge names</td></tr><tr ><td style="color: #161120;text-align: center;">9</td><td style=";">Name Case</td><td style=";">First Upper</td><td style=";">Used by Get Judge Names' macro. 'First Upper' means first letter must be Upper case. Also allowed are 'any', 'Upper', 'lower'</td></tr></tbody></table><p style="width:6em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #A6AAB6;border-top:none;text-align: center;background-color: #E0E0F0;color: #161120">Parameters</p><br /><br />

3) Import the BrowseForFolder code from here: http://www.oaltd.co.uk/MVP/Default.htm

4) Insert this code into a module (replaces all existing code from this thread)

Option Explicit
Const miConcurValue As Integer = 0
Const miDissentValue As Integer = 1
Const miTookNoPartValue As Integer = 9
Const miUnsureMarkerValue As Integer = 10

Const msResultsSheetName As String = "Binary"

Dim miMinLength As Long
Dim mobjIgnoreWords As Object
Dim msaNameCases() As String
Dim msSourceSheet As String
Dim msVotingRecordColumn As String
Dim msCaseNumberColumn As String
Dim msFileFolder As String
Dim msFileFilter As String

Sub GetJudgeNames()
Dim bValid As Boolean

Dim iCol As Integer
Dim iCasePtr As Integer

Dim lptr As Long, lPtr1 As Long
Dim lFileNum As Long

Dim objCandidates As Object
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object

Dim rCur As Range, rSourceRange As Range

Dim sCurFile As String
Dim sCurVotingRecord As String, saVRSplit() As String, sCurChar As String, sCurCandidate As String

Dim vaNameEntry As Variant, vaItems() As Variant, vCurKey As Variant

Dim wbCur As Workbook
Dim wsSource As Worksheet

'-- Get parameters, exit if errors found --
If GetParameters = True Then Exit Sub

'-- Initialise Candidates dictionary --
Set objCandidates = Nothing
Set objCandidates = CreateObject("Scripting.Dictionary")

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(msFileFolder)

With Application
    .EnableEvents = False
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

For Each objFile In objFolder.Files
    lFileNum = lFileNum + 1
    If LCase$(objFile.Name) Like msFileFilter Then
        If objFile.Name <> ThisWorkbook.Name Then
            sCurFile = msFileFolder & Application.PathSeparator & objFile.Name
            Set wbCur = Nothing
            On Error Resume Next
            With Application
                .ScreenUpdating = True
                .StatusBar = "Checking file " & lFileNum & " of " & objFolder.Files.Count & ": " & sCurFile
                .ScreenUpdating = False
            End With
            Set wbCur = Workbooks.Open(Filename:=sCurFile, ReadOnly:=True)
            If Not (wbCur Is Nothing) Then
                Set wsSource = Nothing
                Set wsSource = wbCur.Sheets(msSourceSheet)
                On Error GoTo 0
                If Not (wsSource Is Nothing) Then

                    Set rSourceRange = Intersect(wsSource.UsedRange, wsSource.Columns(msVotingRecordColumn))
                    For Each rCur In rSourceRange
                        sCurVotingRecord = CStr(rCur.Value)
                        For lptr = 1 To Len(sCurVotingRecord)
                            sCurChar = Mid$(sCurVotingRecord, lptr, 1)
                            If LCase$(sCurChar) = UCase$(sCurChar) And sCurChar <> "'" Then Mid$(sCurVotingRecord, lptr, 1) = " "
                        Next lptr
                        sCurVotingRecord = WorksheetFunction.Trim(sCurVotingRecord)
                        If sCurVotingRecord <> "" Then
                            saVRSplit = Split(sCurVotingRecord, " ")
                            For lptr = 0 To UBound(saVRSplit)
                                sCurCandidate = LCase$(saVRSplit(lptr))
                                If Len(sCurCandidate) >= miMinLength Then
                                    If mobjIgnoreWords.exists(sCurCandidate) = False Then
                                        bValid = False
                                        For iCasePtr = 0 To UBound(msaNameCases)
                                            Select Case msaNameCases(iCasePtr)
                                            Case "any"
                                                bValid = True
                                                Exit For
                                            Case "firstupper"
                                                If Left$(saVRSplit(lptr), 1) = UCase$(Left$(saVRSplit(lptr), 1)) Then
                                                    bValid = True
                                                    Exit For
                                                End If
                                            Case "upper"
                                                If UCase$(sCurCandidate) = saVRSplit(lptr) Then
                                                    bValid = True
                                                    Exit For
                                                End If
                                            Case "lower"
                                                If sCurCandidate = saVRSplit(lptr) Then
                                                    bValid = True
                                                    Exit For
                                                End If
                                            End Select
                                        Next iCasePtr
                    
                                        If bValid Then
                                            ReDim vaNameEntry(1 To 2)
                                            If objCandidates.exists(sCurCandidate) Then
                                                vaNameEntry = objCandidates.Item(sCurCandidate)
                                                objCandidates.Remove Key:=sCurCandidate
                                            Else
                                                vaNameEntry(1) = saVRSplit(lptr)
                                                vaNameEntry(2) = 0
                                            End If
                                            vaNameEntry(2) = Val(vaNameEntry(2)) + 1
                                            objCandidates.Add Key:=sCurCandidate, Item:=vaNameEntry
                                        End If
                                    End If
                                End If
                            Next lptr
                        End If
                    Next rCur

                End If
                wbCur.Close
                
            Else
                On Error GoTo 0
            End If
            
        End If
    End If
Next objFile

'-- Extract candidate names plus scores into array --
ReDim vaItems(1 To objCandidates.Count + 1, 1 To 2)
lptr = 1
vaItems(1, 1) = "Judge"
vaItems(1, 2) = "Score"
For Each vCurKey In objCandidates.keys
    lptr = lptr + 1
    vaNameEntry = objCandidates.Item(vCurKey)
    vaItems(lptr, 1) = vaNameEntry(1)
    vaItems(lptr, 2) = vaNameEntry(2)
Next vCurKey

'-- Bubblesort the array into descending frequency --
ReDim vaNameEntry(1 To 2)
For lptr = 2 To UBound(vaItems, 1) - 1
    For lPtr1 = lptr + 1 To UBound(vaItems, 1)
        If vaItems(lptr, 2) < vaItems(lPtr1, 2) Then
            For iCol = 1 To 2
                vaNameEntry(iCol) = vaItems(lptr, iCol)
                vaItems(lptr, iCol) = vaItems(lPtr1, iCol)
                vaItems(lPtr1, iCol) = vaNameEntry(iCol)
            Next iCol
        End If
    Next lPtr1
Next lptr

With Sheets(msResultsSheetName)
    .UsedRange.ClearContents
    ReDim Preserve vaItems(1 To UBound(vaItems, 1), 1 To 1)
    .Range("A1").Resize(UBound(vaItems, 1), UBound(vaItems, 2)).Value = vaItems
End With

mobjIgnoreWords.RemoveAll
Set mobjIgnoreWords = Nothing

objCandidates.RemoveAll
Set objCandidates = Nothing

With Application
    .EnableEvents = True
    .DisplayAlerts = True
    .ScreenUpdating = True
    .StatusBar = False
End With

End Sub

Private Function GetFolder(Optional Text As String = "Please select folder containing input files") As String
Dim RetStr As String, Flags As Long, DoCenter As Boolean

Flags = BIF_RETURNONLYFSDIRS
'Flags = Flags + BIF_EDITBOX
'Flags = Flags + BIF_VALIDATE
'Flags = Flags + BIF_STATUSTEXT
'Flags = Flags + BIF_BROWSEINCLUDEFILES
'Flags = Flags + BIF_NEWDIALOGSTYLE
DoCenter = True
GetFolder = GetDirectory(CurDir, Flags, DoCenter, "Please select a location to store data files")
End Function

Private Function GetParameters() As Boolean
'** Return True if error **
Dim bErrorFound As Boolean
Dim iPtr As Integer
Dim rCur As Range
Dim sCurKeyword As String, sCurValue As String, saSplit() As String

With Sheets("Parameters")
    For Each rCur In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        sCurKeyword = UCase$(Replace((CStr(rCur.Value)), " ", ""))
        sCurValue = CStr(rCur.Offset(, 1))
        Select Case sCurKeyword
        
        Case "FOLDER"
            If sCurValue = "" Then
                sCurValue = GetFolder()
                rCur.Offset(, 1).Value = sCurValue
            End If
            msFileFolder = sCurValue
            If sCurValue = "" Then bErrorFound = True
            
        Case "FILEFILTER"
            msFileFilter = LCase$(sCurValue)
            
        Case "SOURCESHEET"
            msSourceSheet = sCurValue
            
        Case "VOTINGRECORDCOLUMN"
            msVotingRecordColumn = sCurValue
            
        Case "CASENUMBERCOLUMN"
            msCaseNumberColumn = sCurValue
            
        Case "NOISEWORDS"
            '-- Store words to be ignored in a dictionary object --
            Set mobjIgnoreWords = Nothing
            If sCurValue <> "" Then
                Set mobjIgnoreWords = CreateObject("Scripting.Dictionary")
                saSplit = Split(LCase$(Replace(sCurValue, " ", "")), ",")
                For iPtr = 0 To UBound(saSplit)
                    On Error Resume Next
                    mobjIgnoreWords.Add Key:=saSplit(iPtr), Item:=saSplit(iPtr)
                    On Error GoTo 0
                Next iPtr
            End If
            
        Case "MINIMUMNAMELENGTH"
            miMinLength = Val(rCur.Offset(, 1))
            
        Case "NAMECASE"
                msaNameCases = Split(LCase$(Replace(sCurValue, " ", "")), ",")
                
        End Select
    Next rCur
End With

GetParameters = bErrorFound
End Function

Sub GetVotingResults()
Dim iResultCol As Integer, iResultsSheetNum As Integer

Dim laStatsResults() As Long, lGrandTotals As Long
Dim lCurFileNum As Long, lCurResult As Long, lCurTotal As Long
Dim lRowEnd As Long, lResultRow As Long, lSourceRow As Long

Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object

Dim rSourceRange As Range, rCur As Range
Dim rJudgeNames As Range

Dim sCurFile As String, sCurVotingRecord As String, sCurJudgeName As String
Dim sMessage As String

Dim vaVotingRecords() As Variant, vaCases() As Variant, vaJudges() As Variant
Dim vaResults() As Variant

Dim wbCur As Workbook
Dim wsSource As Worksheet, wsResults As Worksheet
Dim wsCur As Worksheet

ReDim laStatsResults(0 To miUnsureMarkerValue + miTookNoPartValue + 1)

'-- Get parameters, exit if errors found --
If GetParameters = True Then Exit Sub

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(msFileFolder)

With Application
    .EnableEvents = False
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

'-- Remove all Results sheets except first --
Set wsResults = ThisWorkbook.Sheets(msResultsSheetName)
For Each wsCur In ThisWorkbook.Worksheets
    If LCase$(Left$(wsCur.Name & "123456", Len(msResultsSheetName))) = LCase$(msResultsSheetName) Then
        If Len(wsCur.Name) <> Len(msResultsSheetName) Then wsCur.Delete
    End If
Next wsCur

With wsResults.UsedRange
    wsResults.Range("B1", wsResults.Cells(.Row + .Rows.Count, .Column + .Columns.Count).Address).ClearContents
End With

lRowEnd = wsResults.Cells(Rows.Count, "A").End(xlUp).Row
Set rJudgeNames = wsResults.Range("A1:A" & lRowEnd)
vaJudges = rJudgeNames.Value
iResultCol = wsResults.Cells(1, Columns.Count).End(xlToLeft).Column

lCurFileNum = 0
For Each objFile In objFolder.Files
    lCurFileNum = lCurFileNum + 1
    If LCase$(objFile.Name) Like msFileFilter Then
        If objFile.Name <> ThisWorkbook.Name Then
            sCurFile = msFileFolder & Application.PathSeparator & objFile.Name
            Set wbCur = Nothing
            On Error Resume Next
            With Application
                .ScreenUpdating = True
                .StatusBar = "Reading file " & lCurFileNum & " of " & objFolder.Files.Count & ": " & sCurFile
                .ScreenUpdating = False
            End With
            Set wbCur = Workbooks.Open(Filename:=sCurFile, ReadOnly:=True)
            If Not (wbCur Is Nothing) Then
                Set wsSource = Nothing
                Set wsSource = wbCur.Sheets(msSourceSheet)
                On Error GoTo 0
                If Not (wsSource Is Nothing) Then
                    
                    lRowEnd = wsSource.Cells(Rows.Count, msVotingRecordColumn).End(xlUp).Row
                    vaVotingRecords = wsSource.Range(msVotingRecordColumn & "1:" & msVotingRecordColumn & lRowEnd).Value
                    vaCases = wsSource.Range(msCaseNumberColumn & "1:" & msCaseNumberColumn & lRowEnd).Value
                    
                    For lSourceRow = 1 To UBound(vaVotingRecords, 1)
                        ReDim vaResults(1 To UBound(vaJudges, 1), 1 To 1)
                        vaResults(1, 1) = vaCases(lSourceRow, 1)
                        sCurVotingRecord = CStr(vaVotingRecords(lSourceRow, 1))
                        For lResultRow = 2 To UBound(vaJudges, 1)
                            sCurJudgeName = CStr(vaJudges(lResultRow, 1))
                            lCurResult = VotingResult(Name:=sCurJudgeName, VotingRecord:=sCurVotingRecord)
                            vaResults(lResultRow, 1) = lCurResult
                            If lCurResult > UBound(laStatsResults) Then lCurResult = UBound(laStatsResults)
                            laStatsResults(lCurResult) = laStatsResults(lCurResult) + 1
                            lGrandTotals = lGrandTotals + 1
                        Next lResultRow
                        iResultCol = iResultCol + 1
                        If iResultCol > Columns.Count Then
                            iResultsSheetNum = iResultsSheetNum + 1
                            Set wsResults = ThisWorkbook.Sheets.Add(after:=wsResults)
                            wsResults.Name = msResultsSheetName & " " & iResultsSheetNum
                            wsResults.Range(rJudgeNames.Address).Value = rJudgeNames.Value
                            iResultCol = 2
                        End If
                        With wsResults
                            .Range(.Cells(1, iResultCol).Address, _
                                   .Cells(UBound(vaResults, 1), iResultCol).Address).Value = vaResults
                        End With
                    Next lSourceRow
                    
                End If
                wbCur.Close
            End If
        End If
    End If
Next objFile

With Application
    .EnableEvents = True
    .DisplayAlerts = True
    .ScreenUpdating = True
    .StatusBar = False
    .Calculation = xlCalculationAutomatic
End With

'-- Show statistics --
lCurResult = laStatsResults(miConcurValue)
lCurTotal = lCurResult
sMessage = Right$("      " & lCurResult, 7) & " Concurs" & vbCrLf

lCurResult = laStatsResults(miDissentValue)
lCurTotal = lCurTotal + lCurResult
sMessage = sMessage & _
           Right$("      " & lCurResult, 7) & " Dissents" & vbCrLf

lCurResult = laStatsResults(miTookNoPartValue)
lCurTotal = lCurTotal + lCurResult
sMessage = sMessage & _
           Right$("      " & lCurResult, 7) & " Non-Participations" & vbCrLf
                
lCurResult = laStatsResults(miConcurValue + miUnsureMarkerValue)
lCurTotal = lCurTotal + lCurResult
sMessage = sMessage & _
           Right$("      " & lCurResult, 7) & " Unsafe Concurs" & vbCrLf
                
lCurResult = laStatsResults(miDissentValue + miUnsureMarkerValue)
lCurTotal = lCurTotal + lCurResult
sMessage = sMessage & _
           Right$("      " & lCurResult, 7) & " Unsafe Dissents" & vbCrLf

lCurResult = laStatsResults(miTookNoPartValue + miTookNoPartValue)
lCurTotal = lCurTotal + lCurResult
sMessage = sMessage & _
           Right$("      " & lCurResult, 7) & " Unsafe Non-Participations" & vbCrLf

sMessage = sMessage & _
           Right$("      " & lCurTotal, 7) & " Total"

lGrandTotals = lGrandTotals + 1

If lGrandTotals = lCurTotal Then
    MsgBox prompt:=sMessage, _
            Buttons:=vbOKOnly + vbInformation, _
            Title:="Summary Statistics"
Else
    sMessage = "WARNING - Totals do not match" & vbCrLf & vbCrLf & sMessage & vbCrLf & vbCrLf & _
             "All Records: " & lGrandTotals & vbCrLf & "Discrepancy: " & Abs(lGrandTotals - lCurTotal)
    MsgBox prompt:=sMessage, _
            Buttons:=vbOKOnly + vbExclamation, _
            Title:="Summary Statistics"
End If

End Sub

Function VotingResult(ByVal Name As String, ByVal VotingRecord As String) As Long
'** Concur value = 0
'** Dissent value = 1
'** did not participate value = 9
'** If unsure 10 is added to value

Dim iPtr As Integer, iNamePtr  As Integer, iVotePtr As Integer
Dim iVotingResult As Integer, iUnsureMarker As Integer
Dim sChar As String, sVotingRecord As String, saVotingRecord() As String

Name = Trim$(LCase$(Name))

'-- convert all non-alphabetics to spaces --
For iPtr = 1 To Len(VotingRecord)
    sChar = LCase$(Mid$(VotingRecord, iPtr, 1))
    If sChar <> "'" And sChar = UCase$(sChar) Then sChar = " "
    sVotingRecord = sVotingRecord & sChar
Next iPtr

iUnsureMarker = 0
sVotingRecord = WorksheetFunction.Trim(sVotingRecord)

sVotingRecord = Replace(sVotingRecord, "concurring in part", "dissent")
sVotingRecord = Replace(sVotingRecord, "not participate", "notparticipate")
sVotingRecord = Replace(sVotingRecord, "took no part", "notparticipate")

If Len(Trim$(sVotingRecord)) <> 0 Then
    saVotingRecord = Split(sVotingRecord, " ")
    For iPtr = UBound(saVotingRecord) To 0 Step -1
         If saVotingRecord(iPtr) = Name Then
            For iNamePtr = iPtr + 1 To UBound(saVotingRecord)
                Select Case saVotingRecord(iNamePtr)
                Case "concur", "concurs", "concurring", "concurred"
                    VotingResult = miConcurValue + iUnsureMarker
                    Exit Function
                Case "dissent", "dissents", "dissenting", "dissented"
                    VotingResult = miDissentValue + iUnsureMarker
                    Exit Function
                Case "notparticipate"
                    VotingResult = miTookNoPartValue + iUnsureMarker
                    Exit Function
                End Select
            Next iNamePtr
            iUnsureMarker = miUnsureMarkerValue
         End If
    Next iPtr
End If
VotingResult = miTookNoPartValue + iUnsureMarker
End Function

I have tested this in 2003, but not 2007.

 

[al_b_cnu]

Hi Danny,

apologies - I've left a statement near the end of the GetVotingResults macro:

lGrandTotals = lGrandTotals + 1

This should be removed - I inserted it to artificially create a discrepancy to test the summary message code.