Solved

Excel 2007 vba error: "Run-time error 1004: Unable to set the text property fo the Characters Class"

Posted on 2009-06-28
4
2,786 Views
Last Modified: 2013-11-25
Several users of the attached workbook and add in are getting this error: Run-time error 1004: Unable to set the text property fo the Characters Class. Any ideas why? Other users don't get it alt all. Thanks!

*I have changed the add in file to an xls so that I can upload it for you to see the code.
09-10-Bmrks-2nd-gr.xls
Add-In-Code.xls
0
Comment
Question by:McQMom
  • 2
  • 2
4 Comments
 
LVL 81

Expert Comment

by:zorvek (Kevin Jones)
ID: 24732783
The file "Add-In-Code.xls" does not contain any code.

The file "09-10-Bmrks-2nd-gr.xls" is password protected.

Kevin
0
 

Author Comment

by:McQMom
ID: 24732970
Sorry. Here's the unlocked file. I've copy & pasted the add in code down below. Thanks.
Private Sub Workbook_AddinInstall()

    RUNME

End Sub
 

Private Sub Workbook_AddinUninstall()

    UNRUNME

End Sub
 

Option Explicit 'Top of module !
 

Public Const CSIDL_DESKTOP = &H0 '{desktop}

Public Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)

Public Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs

Public Const CSIDL_RECENT = &H8 '{user}\Recent
 

Public Declare Function SHGetPathFromIDList Lib "shell32" _

   Alias "SHGetPathFromIDListA" _

  (ByVal pidl As Long, _

   ByVal pszPath As String) As Long
 

Public Declare Function SHGetSpecialFolderLocation Lib "shell32" _

   (ByVal hwndOwner As Long, _

    ByVal nFolder As Long, _

    pidl As Long) As Long
 

Public Declare Sub CoTaskMemFree Lib "ole32" _

   (ByVal pv As Long)
 

Dim objWshShell As Object

Dim objShortcut As Object
 

Function GetSpecialFolderLocation(CSIDL As Long) As String

Dim sPath As String

Dim pidl As Long

If SHGetSpecialFolderLocation(1, CSIDL, pidl) = 0 Then

   sPath = Space$(260)

   If SHGetPathFromIDList(ByVal pidl, ByVal sPath) Then

      GetSpecialFolderLocation = Left(sPath, InStr(sPath, _

        Chr$(0)) - 1)

   End If

   Call CoTaskMemFree(pidl)

 End If

End Function
 

Public Function DesktopLocation() As String

    DesktopLocation = GetSpecialFolderLocation(&H10)

End Function
 
 

Public Sub Import()

    Dim fPath As String

    Dim fName As String

    Dim xlImportFrom As Workbook

    Dim xlImportSheet As Worksheet

    Dim xlImportTo As Workbook

    Dim xlClassData As Worksheet

    Dim currentCol As Long

    Dim BenchRowCount As Long

    Dim bRow As Long

    Dim sRow As Long

    Dim lastColName As String

    Dim lastTestNumber As Long

    Dim newColName As String

    Dim wasOpen As Boolean

    Dim TestNumber As String

    Dim i As Long

    Dim FoundRow As Variant

    Dim FoundValue As Variant

    Dim stName As String

    Dim stID As String

    Dim stScore As String

    Dim rng As Range

    Dim SplitStr As Variant

    Dim FoundStudentEntry As Boolean

    

    

    Set xlImportTo = ActiveWorkbook

    Set xlClassData = xlImportTo.Worksheets("Class Data")

    

    SplitStr = Strings.Split(Application.Caller, "_")

    TestNumber = SplitStr(1)

    currentCol = CInt(TestNumber) + 2

    

    fPath = DesktopLocation & "\NewReport.xls"

    fName = GetWBName(fPath)

    If Not IsWbOpen(fName) Then

        Set xlImportFrom = Workbooks.Open(fPath)

        wasOpen = False

    Else

        Set xlImportFrom = Workbooks(fName)

        wasOpen = True

    End If

    

    Set xlImportSheet = xlImportFrom.Worksheets(1)

    BenchRowCount = Application.WorksheetFunction.CountA(xlClassData.Range("a3:a150")) + 2

    SourceRowCount = Application.WorksheetFunction.CountA(xlImportSheet.Range("a12:a2000")) + 11

    

    For sRow = 13 To SourceRowCount

        'look for values not in benchsheet

        Set FoundValue = xlClassData.Range("b:b").Find(what:=xlImportSheet.Range("B" & sRow).Value, LookIn:=xlValues, LookAt:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)

        

        If FoundValue Is Nothing Then 'may need to modify to use existing student info

            stName = xlImportSheet.Range("A" & sRow)

            stID = xlImportSheet.Range("B" & sRow)

            'Find the first occurrence of "Student" and replace it.  Otherwise, insert a row and fill it

            bRow = 4

            Do While UCase(Left$(xlClassData.Cells(bRow, 1).Value, 7)) <> "STUDENT" And bRow <= BenchRowCount

                bRow = bRow + 1

            Loop

            If bRow <= BenchRowCount Then

                xlClassData.Cells(bRow, 1) = stName

                xlClassData.Cells(bRow, 2) = stID

                FoundStudentEntry = True

            End If

            

            

            If Not FoundStudentEntry Then

                'Insert a row

                xlClassData.Cells(BenchRowCount + 1, 1).EntireRow.Insert

                xlClassData.Cells(BenchRowCount + 1, 1) = stName

                xlClassData.Cells(BenchRowCount + 1, 2) = stID

                BenchRowCount = BenchRowCount + 1

            End If

        End If

    Next sRow

    

    For bRow = 4 To BenchRowCount

        Set FoundValue = xlImportSheet.Range("b:b").Find(what:=xlClassData.Range("B" & bRow).Value, _

            LookIn:=xlValues, LookAt:=xlWhole, searchorder:=xlByRows, _

            searchdirection:=xlNext, MatchCase:=False)

        If Not FoundValue Is Nothing Then

            stScore = FoundValue.Offset(0, 1).Value

            xlClassData.Cells(bRow, currentCol).Value = stScore

            xlImportTo.Activate

            xlClassData.Activate

'            Range("A" & bRow & ":" & "Q" & bRow).Select

'            With Selection.Borders(xlEdgeLeft)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

'            With Selection.Borders(xlEdgeTop)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

'            With Selection.Borders(xlEdgeBottom)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

'            With Selection.Borders(xlEdgeRight)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

'            With Selection.Borders(xlInsideVertical)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

        End If

                

    Next bRow

    

    xlImportTo.Activate

    If Not wasOpen Then xlImportFrom.Close

    Set xlImportFrom = Nothing

    

    

        

End Sub
 
 

Public Sub Import1stGrade()

    Dim fPath As String

    Dim fName As String

    Dim xlImportFrom As Workbook

    Dim xlImportSheet As Worksheet

    Dim xlImportTo As Workbook

    Dim xlClassData As Worksheet

    Dim currentCol As Long

    Dim BenchRowCount As Long

    Dim bRow As Long

    Dim sRow As Long

    Dim lastColName As String

    Dim lastTestNumber As Long

    Dim newColName As String

    Dim wasOpen As Boolean

    Dim TestNumber As String

    Dim i As Long

    Dim FoundRow As Variant

    Dim FoundValue As Variant

    Dim stName As String

    Dim stID As String

    Dim stScore As String

    Dim rng As Range

    Dim SplitStr As Variant

    Dim FoundStudentEntry As Boolean

    

    

    Set xlImportTo = ActiveWorkbook

    Set xlClassData = xlImportTo.Worksheets("Class Data")

    

    SplitStr = Strings.Split(Application.Caller, "_")

    TestNumber = SplitStr(1)

    currentCol = CInt(TestNumber) + 2

    

    'to handle second grid columns

    If currentCol > 14 Then currentCol = currentCol + 4

    

    fPath = DesktopLocation & "\NewReport.xls"

    fName = GetWBName(fPath)

    If Not IsWbOpen(fName) Then

        Set xlImportFrom = Workbooks.Open(fPath)

        wasOpen = False

    Else

        Set xlImportFrom = Workbooks(fName)

        wasOpen = True

    End If

    

    Set xlImportSheet = xlImportFrom.Worksheets(1)

    BenchRowCount = Application.WorksheetFunction.CountA(xlClassData.Range("a3:a2000")) + 2

    SourceRowCount = Application.WorksheetFunction.CountA(xlImportSheet.Range("a12:a2000")) + 11

    

    For sRow = 13 To SourceRowCount

        'look for values not in benchsheet

        Set FoundValue = xlClassData.Range("b:b").Find(what:=xlImportSheet.Range("B" & sRow).Value, LookIn:=xlValues, LookAt:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)

        

        If FoundValue Is Nothing Then 'may need to modify to use existing student info

            stName = xlImportSheet.Range("A" & sRow)

            stID = xlImportSheet.Range("B" & sRow)

            'Find the first occurrence of "Student" and replace it.  Otherwise, insert a row and fill it

            bRow = 4

            Do While UCase(Left$(xlClassData.Cells(bRow, 1).Value, 7)) <> "STUDENT" And bRow <= BenchRowCount

                bRow = bRow + 1

            Loop

            If bRow <= BenchRowCount Then

                xlClassData.Cells(bRow, 1) = stName

                xlClassData.Cells(bRow, 2) = stID

                xlClassData.Cells(bRow, 17) = stName

                xlClassData.Cells(bRow, 18) = stID

                FoundStudentEntry = True

            End If

            

            

            If Not FoundStudentEntry Then

                'Insert a row

                xlClassData.Cells(BenchRowCount + 1, 1).EntireRow.Insert

                xlClassData.Cells(BenchRowCount + 1, 1) = stName

                xlClassData.Cells(BenchRowCount + 1, 2) = stID

                xlClassData.Cells(BenchRowCount + 1, 17) = stName

                xlClassData.Cells(BenchRowCount + 1, 18) = stID

                BenchRowCount = BenchRowCount + 1

            End If

        End If

    Next sRow

    

    For bRow = 4 To BenchRowCount

        Set FoundValue = xlImportSheet.Range("b:b").Find(what:=xlClassData.Range("B" & bRow).Value, _

            LookIn:=xlValues, LookAt:=xlWhole, searchorder:=xlByRows, _

            searchdirection:=xlNext, MatchCase:=False)

        If Not FoundValue Is Nothing Then

            stScore = FoundValue.Offset(0, 1).Value

            xlClassData.Cells(bRow, currentCol).Value = stScore

            xlImportTo.Activate

            xlClassData.Activate

'            Range("A" & bRow & ":" & "Q" & bRow).Select

'            With Selection.Borders(xlEdgeLeft)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

'            With Selection.Borders(xlEdgeTop)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

'            With Selection.Borders(xlEdgeBottom)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

'            With Selection.Borders(xlEdgeRight)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

'            With Selection.Borders(xlInsideVertical)

'                .LineStyle = xlContinuous

'                .Weight = xlThin

'            End With

        End If

                

    Next bRow

    

    xlImportTo.Activate

    If Not wasOpen Then xlImportFrom.Close

    Set xlImportFrom = Nothing

    

    

        

End Sub
 
 

Public Sub ImportProgress()

    Dim fPath As String

    Dim fName As String

    Dim xlImportFrom As Workbook

    Dim xlImportSheet As Worksheet

    Dim xlImportTo As Workbook

    Dim xlClassData As Worksheet

    Dim currentCol As Long

    Dim BenchRowCount As Long

    Dim LastIDRow As Long

    Dim bRow As Long

    Dim sRow As Long

    Dim lastColName As String

    Dim lastTestNumber As Long

    Dim newColName As String

    Dim wasOpen As Boolean

    Dim TestNumber As String

    Dim i As Long

    Dim FoundRow As Variant

    Dim FoundValue As Variant

    Dim stName As String

    Dim stID As String

    Dim stScore As String

    Dim rng As Range

    Dim SplitStr As Variant

    Dim FoundStudentEntry As Boolean

    Dim StepVal As Integer

    Dim r1 As Long, r2 As Long, ir As Long

    

    Set xlImportTo = ActiveWorkbook

    Set xlClassData = xlImportTo.Worksheets(1)

    

    

    fPath = DesktopLocation & "\NewReport.xls"

    fName = GetWBName(fPath)

    If Not IsWbOpen(fName) Then

        Set xlImportFrom = Workbooks.Open(fPath)

        wasOpen = False

    Else

        Set xlImportFrom = Workbooks(fName)

        wasOpen = True

    End If

    

    Set xlImportSheet = xlImportFrom.Worksheets(1)

    

    

    For r = 4 To 2000

        If Trim(xlClassData.Range("a" & r).Value) = "ID" Then

            r1 = r

            For ir = r + 1 To 2000

                If Trim(xlClassData.Range("a" & ir).Value) = "ID" Then

                    r2 = ir

                    Exit For

                End If

            Next ir

        Exit For

        End If

    Next r

            

    StepVal = r2 - r1

        

    

    For r = 2000 To 4 Step -1

        If Trim(xlClassData.Range("a" & r).Value) = "ID" Then

            LastIDRow = r

            Exit For

        End If

    Next r

    For r = 2000 To 4 Step -1

        If Trim(xlClassData.Range("a" & r).Value) = "Intervention Changes" Then

            BenchRowCount = r

            Exit For

        End If

    Next r

    

    

    

    

    

    

    

    SourceRowCount = Application.WorksheetFunction.CountA(xlImportSheet.Range("a12:a2000")) + 11

    

    For sRow = 13 To SourceRowCount

        'look for values not in benchsheet

        Set FoundValue = xlClassData.Range("a:a").Find(what:=xlImportSheet.Range("B" & sRow).Value, LookIn:=xlValues, LookAt:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)

        

        If FoundValue Is Nothing Then 'may need to modify to use existing student info

            stName = xlImportSheet.Range("A" & sRow)

            stID = xlImportSheet.Range("B" & sRow)

            'Find the first occurrence of "Student" and replace it.  Otherwise, insert a row and fill it

            bRow = 4

            Do While UCase(Left$(xlClassData.Cells(bRow, 1).Value, 7)) <> "STUDENT" And bRow <= BenchRowCount

                bRow = bRow + StepVal

            Loop

            If bRow <= BenchRowCount Then

                xlClassData.Cells(bRow, 1) = stName

                xlClassData.Cells(bRow + 1, 1) = stID

                FoundStudentEntry = True

            End If

            

            

            If Not FoundStudentEntry Then

                'Insert a row, may have to copy and paste a section?

                xlClassData.Range("A" & BenchRowCount - StepVal & ":AS" & BenchRowCount).Copy

                xlClassData.Paste Destination:=Worksheets(1).Range("A" & BenchRowCount + 1 & ":AS" & BenchRowCount + StepVal)
 

                xlClassData.Cells(LastIDRow + StepVal - 1, 1) = stName

                xlClassData.Cells(LastIDRow + StepVal, 1) = stID

                BenchRowCount = BenchRowCount + 1

            End If

        End If

    Next sRow

    

    

    xlImportTo.Activate

    If Not wasOpen Then

        xlImportFrom.Close savechanges:=False

        Set xlImportFrom = Nothing
 

    End If

    

    

        

End Sub
 
 

Public Sub RUNME()

    'place cursor here and hit F5

    Select Case WhichToInstall

        Case "OtherGrade":

            StudentScoresInstall

        Case "FirstGrade":

            StudentScores1stGradeInstall

        Case "Progress":

            ProgressInstall

        Case Else:

            'do nothing

    End Select

End Sub
 
 

Public Sub UNRUNME()

    Select Case WhichToInstall

        Case "OtherGrade":

            StudentScoresUninstall

        Case "FirstGrade":

            StudentScores1stGradeUninstall

        Case "Progress":

            ProgressUninstall

        Case Else:

            'do nothing

    End Select
 

End Sub
 
 

Public Function IsWbOpen(wbName As String) As Boolean

    Dim i As Long

    For i = Workbooks.Count To 1 Step -1

        If Workbooks(i).Name = wbName Then Exit For

    Next

    If i <> 0 Then IsWbOpen = True

End Function

Public Function GetWBName(wbPath As String) As String

    Dim i As Long

    Dim ls As Long

    

    For i = Len(wbPath) To 1 Step -1

        If Mid$(wbPath, i, 1) = "\" Then

            ls = i

            Exit For

        End If

    Next i

    

    GetWBName = Mid$(wbPath, ls + 1)

End Function
 

Public Sub StudentScoresInstall()

    'delete all buttons on sheet1

    Dim YW As Workbook

    Set YW = ActiveWorkbook

    Dim BS As Worksheet

    Set BS = YW.Worksheets("Class Data")

    Dim sh As Shape

    Dim c As Long

    Dim cTop As Variant

    Dim cLeft As Variant

    Dim cWidth As Variant

    

    For Each sh In BS.Shapes

        If sh.Type = msoFormControl Then sh.Delete

    Next

    

    'find coordinates and information for top row of range, place buttons there

    'row 3 is the start

    For c = 3 To 17

        Set sh = BS.Shapes.AddFormControl(xlButtonControl, BS.Cells(3, c).Left, BS.Cells(3, c).Top, BS.Cells(3, c).Width, BS.Cells(3, c).Height)

        sh.Name = "Button_" & CStr(c - 2)

        sh.OnAction = "StudentScores.xla!Import"

    Next c

    

    For Each sh In BS.Shapes

        If sh.Type = msoFormControl Then

            Select Case sh.Name

                Case "Button_1", "Button_6", "Button_11":

                    sh.Select

                    Selection.Characters.Text = "MA"

                Case "Button_2", "Button_7", "Button_12":

                    sh.Select

                    Selection.Characters.Text = "Z"

                Case "Button_3", "Button_8", "Button_13":

                    sh.Select

                    Selection.Characters.Text = "RCBM"

                Case "Button_4", "Button_9", "Button_14":

                    sh.Select

                    Selection.Characters.Text = "TWW"

                Case "Button_5", "Button_10", "Button_15":

                    sh.Select

                    Selection.Characters.Text = "CWS"

            End Select

        End If

    Next

    BS.Cells(4, 3).Select
 

End Sub

Public Sub StudentScoresUninstall()

    'delete all buttons on sheet1

    Dim YW As Workbook

    Set YW = ActiveWorkbook

    Dim BS As Worksheet

    Set BS = YW.Worksheets("Class Data")

    Dim sh As Shape

    Dim c As Long

    Dim cTop As Variant

    Dim cLeft As Variant

    Dim cWidth As Variant

    

    For Each sh In BS.Shapes

        If sh.Type = msoFormControl Then sh.Delete

    Next

    
 

End Sub

Public Sub StudentScores1stGradeInstall()

    'delete all buttons on sheet1

    Dim YW As Workbook

    Set YW = ActiveWorkbook

    Dim BS As Worksheet

    Set BS = YW.Worksheets("Class Data")

    Dim sh As Shape

    Dim c As Long

    Dim cTop As Variant

    Dim cLeft As Variant

    Dim cWidth As Variant

    

    For Each sh In BS.Shapes

        If sh.Type = msoFormControl Then sh.Delete

    Next

    

    'find coordinates and information for top row of range, place buttons there

    'row 3 is the start

    For c = 3 To 14

        Set sh = BS.Shapes.AddFormControl(xlButtonControl, BS.Cells(3, c).Left, BS.Cells(3, c).Top, BS.Cells(3, c).Width, BS.Cells(3, c).Height)

        sh.Name = "Button_" & CStr(c - 2)

        sh.OnAction = "StudentScores.xla!Import1stGrade"

    Next c

    For c = 19 To 36

        Set sh = BS.Shapes.AddFormControl(xlButtonControl, BS.Cells(3, c).Left, BS.Cells(3, c).Top, BS.Cells(3, c).Width, BS.Cells(3, c).Height)

        sh.Name = "Button_" & CStr(c - 6)

        sh.OnAction = "StudentScores.xla!Import1stGrade"

    Next c

    

    

    For Each sh In BS.Shapes

        If sh.Type = msoFormControl Then

            Select Case sh.Name

                Case "Button_1", "Button_5", "Button_9":

                    sh.Select

                    Selection.Characters.Text = "MN"

                Case "Button_2", "Button_6", "Button_10":

                    sh.Select

                    Selection.Characters.Text = "QD"

                Case "Button_3", "Button_7", "Button_11":

                    sh.Select

                    Selection.Characters.Text = "NI"

                Case "Button_4", "Button_8", "Button_12":

                    sh.Select

                    Selection.Characters.Text = "OC"

                Case "Button_13", "Button_19", "Button_25":

                    sh.Select

                    Selection.Characters.Text = "LNF"

                Case "Button_14", "Button_20", "Button_26":

                    sh.Select

                    Selection.Characters.Text = "LSF"

                Case "Button_15", "Button_21", "Button_27":

                    sh.Select

                    Selection.Characters.Text = "PSF"

                Case "Button_16", "Button_22", "Button_28":

                    sh.Select

                    Selection.Characters.Text = "NWF"

                Case "Button_17", "Button_23", "Button_29":

                    sh.Select

                    Selection.Characters.Text = "TWW"

                Case "Button_18", "Button_24", "Button_30":

                    sh.Select

                    Selection.Characters.Text = "CWS"

            End Select

        End If

    Next

    BS.Cells(4, 3).Select
 

End Sub

Public Sub StudentScores1stGradeUninstall()

    'delete all buttons on sheet1

    Dim YW As Workbook

    Set YW = ActiveWorkbook

    Dim BS As Worksheet

    Set BS = YW.Worksheets("Class Data")

    Dim sh As Shape

    Dim c As Long

    Dim cTop As Variant

    Dim cLeft As Variant

    Dim cWidth As Variant

    

    For Each sh In BS.Shapes

        If sh.Type = msoFormControl Then sh.Delete

    Next
 

End Sub

Public Sub ProgressInstall()

    'delete all buttons on sheet1

    Dim YW As Workbook

    Set YW = ActiveWorkbook

    Dim BS As Worksheet

    Set BS = YW.Worksheets(1)

    Dim sh As Shape

    Dim c As Long

    Dim cTop As Variant

    Dim cLeft As Variant

    Dim cWidth As Variant

    

    For Each sh In BS.Shapes

        If sh.Type = msoFormControl Then sh.Delete

    Next

    

    'find coordinates and information for top row of range, place buttons there

    'row 3 is the start

    

        Set sh = BS.Shapes.AddFormControl(xlButtonControl, BS.Cells(2, 1).Left, BS.Cells(2, 1).Top, BS.Cells(2, 1).Width, BS.Cells(2, 1).Height)

        sh.Name = "Button_SN"

        sh.OnAction = "StudentScores.xla!ImportProgress"

        sh.Select

        Selection.Characters.Text = "Import Students"

    

    BS.Cells(2, 3).Select
 

End Sub

Public Sub ProgressUninstall()

    'delete all buttons on sheet1

    Dim YW As Workbook

    Set YW = ActiveWorkbook

    Dim BS As Worksheet

    Set BS = YW.Worksheets(1)

    Dim sh As Shape

    

    For Each sh In BS.Shapes

        If sh.Type = msoFormControl Then sh.Delete

    Next
 

End Sub

Public Function WhichToInstall() As String

    Dim YW As Workbook

    Set YW = ActiveWorkbook

    Dim BS As Worksheet

    On Error GoTo EH

    Set BS = YW.Worksheets(1)

    Dim OutputString As String

    

    Select Case True

        Case Trim(BS.Range("Q3").Value) = "Name":

            OutputString = "FirstGrade"

        Case Trim(BS.Range("D1").Value) = "First day of school year:"

            OutputString = "Progress"

        Case Trim(BS.Range("Q3").Value) = "CWS":

            OutputString = "OtherGrade"

        Case Else:

            OutputString = ""

    End Select

    

    WhichToInstall = OutputString
 

Exit Function

EH:

    If Err.Number = 91 Then

        MsgBox "You must open a workbook that is compatible with this Add-in.", vbCritical + vbOKOnly, "StudentScores Add-in Error!"

        End

    End If

    

End Function

Open in new window

09-10-Bmrks-2nd-gr.xls
0
 
LVL 81

Accepted Solution

by:
zorvek (Kevin Jones) earned 500 total points
ID: 24745670
Change the routine "StudentScoresInstall" to:

Public Sub StudentScoresInstall()
    'delete all buttons on sheet1
    Dim YW As Workbook
    Set YW = ActiveWorkbook
    Dim BS As Worksheet
    Set BS = YW.Worksheets("Class Data")
    Dim sh As Shape
    Dim c As Long
    Dim cTop As Variant
    Dim cLeft As Variant
    Dim cWidth As Variant
    Dim ActiveSheet As Object
   
    Set ActiveSheet = YW.ActiveSheet
    BS.Activate
   
    For Each sh In BS.Shapes
        If sh.Type = msoFormControl Then sh.Delete
    Next
   
    'find coordinates and information for top row of range, place buttons there
    'row 3 is the start
    For c = 3 To 17
        Set sh = BS.Shapes.AddFormControl(xlButtonControl, BS.Cells(3, c).Left, BS.Cells(3, c).Top, BS.Cells(3, c).Width, BS.Cells(3, c).Height)
        sh.Name = "Button_" & CStr(c - 2)
        sh.OnAction = "StudentScores.xla!Import"
    Next c
   
    For Each sh In BS.Shapes
        If sh.Type = msoFormControl Then
            Select Case sh.Name
                Case "Button_1", "Button_6", "Button_11":
                    sh.Select
                    Selection.Characters.Text = "MA"
                Case "Button_2", "Button_7", "Button_12":
                    sh.Select
                    Selection.Characters.Text = "Z"
                Case "Button_3", "Button_8", "Button_13":
                    sh.Select
                    Selection.Characters.Text = "RCBM"
                Case "Button_4", "Button_9", "Button_14":
                    sh.Select
                    Selection.Characters.Text = "TWW"
                Case "Button_5", "Button_10", "Button_15":
                    sh.Select
                    Selection.Characters.Text = "CWS"
            End Select
        End If
    Next
    BS.Cells(4, 3).Select
   
    ActiveSheet.Activate
 
End Sub

Kevin
0
 

Author Closing Comment

by:McQMom
ID: 31597747
Perfect. Thanks!
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

919 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now