[Last Call] Learn about multicloud storage options and how to improve your company's cloud strategy. Register Now

x
?
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
Medium Priority
?
2,953 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 2000 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

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

650 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