'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!

Attachment 19484

"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

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.

Does PP count slides from zero?

Simple test code

Code:

---

Sub T()
Dim X
X = slides(0) 'also try Shapes(0) I don't know PP rules
Set x = slides(0)
End sub

---

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.

Here is the code:

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

---

Code:

---

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

---

Code:

---

'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

---

Code:

---

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

---

Code:

---

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

---

Attachment 19506

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.

First, I would make two changes and test them

Code:

---

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

---

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. :)

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

Attachment 19510

Good. That means you fixed the first issue. :thumb:

Code:

---

          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

---

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

Code:

---

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

---

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.

This is what it's showing me.
Attachment 19515

CDate(0) = 12:00:00AM

Quote:

---

Take a look at otr.Paragraphs(2).Text when you get the error

Code:

---

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

---

---

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

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

Quote:

---

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

Code:

---

Sub TestDateZero()
MsgBox CDate(0)
End Sub

---

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

Attachment 19520

And... What did the MsgBox say?

Here is how to redim arrays based on type

Code:

---

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

---

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.