Consulting

Results 1 to 16 of 16

Thread: 'subscript is out of range'

  1. #1

    'subscript is out of range'

    I currently have a Macro running for the attached file that sorts the shapes based on the date in the shape (latest date to older). The macro runs fine on the first page, but on the second page I keep getting an error message saying the 'Subscript is out of range'.

    Also, although the macro works on the first page, the boxes jump to a different position on the page, is there anyway to fix this?

    Can someone help me to figure out what is wrong with this file? Thanks!

    PPT Trial_Sorter.pptm

  2. #2
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    5,871
    Location
    "Subscript Out of Range" means the identifier in the parenthesis does not exist.

    Example slides(21) when there are only 20 slides. (Or 21 if PP counts from zero)
    If counting from zero, the last allowed subscript would be .Count - 1

    If you use names, check for correct speiling
    Please take the time to read the Forum FAQ

  3. #3
    Thanks Sam! So how would I fix this in relation to slide 2 of this file? The number in the parenthesis says 28, and there are exactly 28 objects on the page. Still gives me the "Subscript out of range" error.

  4. #4
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    5,871
    Location
    Does PP count slides from zero?

    Simple test code
    Sub T() 
        Dim X 
        X = slides(0) 'also try Shapes(0) I don't know PP rules
        Set x = slides(0) 
    End Sub 
    
    
    Formatting tags added by mark007
    Where was the error, if any

    I know VBA in general and VBA for Excel in particular, but all MS programs differ slightly in implementing VBA.

    Show us your VBA code, I don't have PP on my computer, But I should understand the code.
    Please take the time to read the Forum FAQ

  5. #5
    Here is the code:

    Option Explicit 
     
    Sub sortDates() 
        Dim rayshapes() As Shape 
        Dim x As Integer 
        Dim y As Integer 
        Dim t As Integer 
        Const initL As Single = 56.29528 
        Const initT As Single = 125.3445 
        Const incL As Single = 122.5583 
        Const incT As Single = 131.2299 
         
        Dim oshp As Shape 
        Dim osld As Slide 
        Set osld = ActiveWindow.Selection.SlideRange(1) 
        ReDim rayshapes(1 To osld.Shapes.Count - 1) 
         
        For Each oshp In osld.Shapes 
            If oshp.Type = msoGroup Then 
                x = x + 1 
                Set rayshapes(x) = oshp '<-- This is where I am getting the error for "subscript out of range"
            End If 'only groups
        Next oshp 
         
        Call SortByDate(rayshapes) 
        t = 0 
        x = 0 
         
        For y = 1 To UBound(rayshapes) 
            x = x + 1 
            If x = 8 Then 
                x = 1 
                t = t + 1 
            End If 
             
            rayshapes(y).Left = initL + (x - 1) * incL 
            rayshapes(y).Top = initT + (t * incT) 
        Next y 
    End Sub 
    
    
    Formatting tags added by mark007

    Sub SortByDate(Arrayin As Variant) 
        Dim b_Cont As Boolean 
        Dim rayShape As Shape 
        Dim lngCount As Long 
        Dim vSwap As Shape 
        Dim dateShape As Shape 
        Dim shp1 As Shape 
        Dim otr As TextRange 
        Dim GI As Shape 
         
        Dim otr2 As TextRange 
        Dim thisDate As Date 
        Dim thisDate2 As Date 
        Dim ipos As Integer 
         
        Do 
            b_Cont = False 
             
            For lngCount = LBound(Arrayin) To UBound(Arrayin) - 1 
                Set rayShape = Arrayin(lngCount) 
                Set dateShape = rayShape.GroupItems(rayShape.GroupItems.Count) 
                Set otr = dateShape.TextFrame.TextRange 
                Debug.Print otr.Text 
                ipos = InStr(otr.Paragraphs(2).Text, "–") 
                 
                If ipos > 0 Then 
                    thisDate = CDate(Left(otr.Paragraphs(2).Text, ipos - 2)) 
                Else 
                    thisDate = CDate(otr.Paragraphs(2).Text) 
                End If 
                 
                Set rayShape = Arrayin(lngCount + 1) 
                Set dateShape = rayShape.GroupItems(rayShape.GroupItems.Count) 
                Set otr2 = dateShape.TextFrame.TextRange 
                ipos = InStr(otr2.Paragraphs(2).Text, "–") 
                 
                If ipos > 0 Then 
                    thisDate2 = CDate(Left(otr2.Paragraphs(2).Text, ipos - 2)) 
                Else 
                    thisDate2 = CDate(otr2.Paragraphs(2).Text) 
                End If 
                 
                If thisDate < thisDate2 Then 
                    Set vSwap = Arrayin(lngCount) 
                    Set Arrayin(lngCount) = Arrayin(lngCount + 1) 
                    Set Arrayin(lngCount + 1) = vSwap 
                    b_Cont = True 
                End If 
            Next lngCount 
        Loop Until Not b_Cont 
         'release objects
        Set vSwap = Nothing 
        Exit Sub 
    End Sub 
    
    
    Formatting tags added by mark007

     'Function getDateHolder(oshp As Shape) As Shape
     'Dim G As Long
     
     'If oshp.Type = msoGroup Then
     'For G = 1 To oshp.GroupItems.Count
     'If oshp.GroupItems(G).HasTextFrame Then
     'If oshp.GroupItems(G).TextFrame.TextRange.Paragraphs.Count = 2 Then
     'Set getDateHolder = oshp.GroupItems(G)
     'Exit Function
     'End If
     'End If
     'Next
     'End If
     'End Function
    
    
    Formatting tags added by mark007
    Sub sortNames() 
        Dim rayshapes() As Shape 
        Dim x As Integer 
        Dim y As Integer 
        Dim t As Integer 
        Const initL As Single = 233.7844 
        Const initT As Single = 153.2876 
        Const incL As Single = 84.08623 
        Const incT As Single = 137.6572 
         
        Dim oshp As Shape 
        Dim osld As Slide 
         
        Set osld = ActiveWindow.Selection.SlideRange(1) 
        ReDim rayshapes(1 To osld.Shapes.Count - 1) 
         
        For Each oshp In osld.Shapes 
            If oshp.Type = msoGroup Then 
                x = x + 1 
                Set rayshapes(x) = oshp 
            End If 'only groups
        Next oshp 
         
        Call SortByName(rayshapes) 
        t = 0 
        x = 0 
         
        For y = 1 To UBound(rayshapes) 
            x = x + 1 
             
            If x = 7 Then 
                x = 1 
                t = t + 1 
            End If 
             
            rayshapes(y).Left = initL + (x - 1) * incL 
            rayshapes(y).Top = initT + (t * incT) 
        Next y 
    End Sub 
    
    
    Formatting tags added by mark007
    Sub SortByName(Arrayin As Variant) 
        Dim b_Cont As Boolean 
        Dim rayShape As Shape 
        Dim rayShape2 As Shape 
        Dim lngCount As Long 
        Dim vSwap As Shape 
        Dim otr As TextRange 
        Dim otr2 As TextRange 
        Dim ipos As Integer 
         
        Do 
            b_Cont = False 
            For lngCount = LBound(Arrayin) To UBound(Arrayin) - 1 
                Set rayShape = Arrayin(lngCount) 
                Set rayShape2 = Arrayin(lngCount + 1) 
                 
                If UCase(rayShape.GroupItems(rayShape.GroupItems.Count).TextFrame.TextRange.Words(2).Text) > UCase(rayShape2.GroupItems(rayShape.GroupItems.Count).TextFrame.TextRange.Words(2).Text) Then 
                    Set vSwap = Arrayin(lngCount) 
                    Set Arrayin(lngCount) = Arrayin(lngCount + 1) 
                    Set Arrayin(lngCount + 1) = vSwap 
                    b_Cont = True 
                End If 
            Next lngCount 
             
        Loop Until Not b_Cont 
         'release objects
        Set vSwap = Nothing 
        Exit Sub 
    End Sub 
    
    
    Formatting tags added by mark007
    Last edited by SamT; 06-15-2017 at 07:37 AM. Reason: Added Code formatting tags and whitespace

  6. #6
    2017-06-15_9-15-55.jpg

    Here is a screenshot of the page. The code sorts the shapes based on the date in the shape (from most recent to earliest). It works on another page for a set of test shapes, but not on these.

  7. #7
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    5,871
    Location
    First, I would make two changes and test them
    Dim rayshapes As Variant 'A Variant can hold any Type and works very slightly different than an Array.
    ReDim rayshapes(1 To osld.Shapes.Count) 'The full Count
    
    
    Formatting tags added by mark007
    Explanation:
    ReDim rayshapes(1 To osld.Shapes.Count - 1) ---The Upper Bound of the array is one less than the Collection Count
    For Each oshp In osld.Shapes
    ...
    x = x + 1 --- Eventually x will equal the collection count, or, 1 more than rayshapes' UBound



    BTW, it looks like you have a good grasp of PP.
    Please take the time to read the Forum FAQ

  8. #8
    I made the changes you suggested but now I'm getting this "type mismatch" error

    2017-06-15_11-17-58.jpg

  9. #9
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    5,871
    Location
    Good. That means you fixed the first issue. :

    Debug.Print otr.Text 
    ipos = InStr(otr.Paragraphs(2).Text, "–") 
     
    If ipos > 0 Then 
        thisDate = CDate(Left(otr.Paragraphs(2).Text, ipos - 2)) 
    Else 
        thisDate = CDate(otr.Paragraphs(2).Text) 
    End If 
    
    
    Formatting tags added by mark007

    From the code above, I assume that the second Para in otr.txt is in the form of either
    "DateString - More text"
    Or just
    "DateString"

    Take a look at otr.Paragraphs(2).Text when you get the error
    If ipos > 0 Then 
        thisDate = CDate(Left(otr.Paragraphs(2).Text, ipos - 2)) 
    Else 
        msgbox otr.Paragraphs(2).Text '<-- add line
        thisDate = CDate(otr.Paragraphs(2).Text) 
    End If 
    
    
    Formatting tags added by mark007
    What is the Format of the Date String?

    BTW, if you indent and space your code like in all the "Code Blocks" above, your code will be much easier to read.
    Please take the time to read the Forum FAQ

  10. #10
    This is what it's showing me.
    2017-06-15_15-05-52.jpg
    Attached Images Attached Images
      To view attachments your post count must be 0 or greater. Your post count is 0 momentarily.

  11. #11
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    5,871
    Location
    CDate(0) = 12:00:00AM

    Take a look at otr.Paragraphs(2).Text when you get the error
    If ipos > 0 Then 
        thisDate = CDate(Left(otr.Paragraphs(2).Text, ipos - 2)) 
    Else 
        msgbox otr.Paragraphs(2).Text '<-- add line
        thisDate = CDate(otr.Paragraphs(2).Text) 
    End If 
    
    
    Formatting tags added by mark007
    Please take the time to read the Forum FAQ

  12. #12
    Where exactly should I be adding the "CDate(0) = 12:00:00AM"?

    Sorry for all the questions. I just want to get this right!

  13. #13
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    5,871
    Location
    Where exactly should I be adding the "CDate(0) = 12:00:00AM"?
    Nowhere.That was a statement of fact. If you convert zero to a date, you get 12:00:00AM as the result

    Example code
    Sub TestDateZero() 
        MsgBox CDate(0) 
    End Sub 
    
    
    Formatting tags added by mark007
    Please take the time to read the Forum FAQ

  14. #14
    I added the line you said to add, but it is still coming up as a "type mismatch" for the line below it.

    2017-06-15_16-50-49.jpg

  15. #15
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    5,871
    Location
    And... What did the MsgBox say?
    Please take the time to read the Forum FAQ

  16. #16
    Here is how to redim arrays based on type

    Sub sortDates()Dim rayshapes() As Shape 
        Dim x As Integer 
        Dim y As Integer 
        Dim t As Integer 
        Const initL As Single = 56.29528 
        Const initT As Single = 125.3445 
        Const incL As Single = 122.5583 
        Const incT As Single = 131.2299 
         
         
        Dim oshp As Shape 
        Dim osld As Slide 
        Set osld = ActivePresentation.Slides(2) 
        ReDim rayshapes(1 To 1) 
        For Each oshp In osld.Shapes 
            If oshp.Type = msoGroup Then 
                x = x + 1 
                Set rayshapes(x) = oshp 
                ReDim Preserve rayshapes(1 To UBound(rayshapes) + 1) 
            End If 'only groups
        Next oshp 
        If UBound(rayshapes) > 1 Then 
             'strip extra value
            ReDim Preserve rayshapes(1 To UBound(rayshapes) - 1) 
        End If 
        Call SortByDate(rayshapes) 
        t = 0 
        x = 0 
        For y = 1 To UBound(rayshapes) 
            x = x + 1 
            If x = 8 Then 
                x = 1 
                t = t + 1 
            End If 
            rayshapes(y).Left = initL + (x - 1) * incL 
            rayshapes(y).Top = initT + (t * incT) 
        Next y 
    End Sub 
    
    
    Formatting tags added by mark007
    The error in the second sub is because there are two type of dashes in the dates and your code ignopres one of them so the result is nor a date.
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •