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,763 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)
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Perfect. Thanks!
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

762 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

6 Experts available now in Live!

Get 1:1 Help Now