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,878 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

696 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