'subscript is out of range'

[Marvin1993]

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!

19484

[SamT]

"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

[Marvin1993]

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.

[SamT]

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 subWhere 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.

[Marvin1993]

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



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



'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



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



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.Wo rds(2).Text) > UCase(rayShape2.GroupItems(rayShape.GroupItems.Count).TextFrame.TextRange.W ords(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

[Marvin1993]

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.

[SamT]

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

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

[Marvin1993]

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

19510

[SamT]

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


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

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.

[Marvin1993]

This is what it's showing me.
19515

[SamT]

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

[Marvin1993]

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

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

[SamT]

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

[Marvin1993]

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

19520

[SamT]

And... What did the MsgBox say?

[John Wilson]

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

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.