Crear macro para generar PPT desde Excel

Me gustaría crear una macro para generar presentación de Power Point, y cargar gráficos y tablas en una Plantilla determinada, en el archivo Excel estan distribuidos los datos en Hojas marcadas de Enero a Febrero, y realizar un formulario o botón que me permita escoger el mes en curso para poder cargar dicha información a la Plantilla. Tengo la siguiente macro, pero me recorre todas las hojas, alguien que me ayude a modificar para poder ejecutarla como lo describo anteriormente. Como mencionó la Macro abre la plantilla, recorre todas las hojas del libro abierto, va buscando tanto tablas como gráficas y las va copiando una a una en la presentación, cuando termina guarda la PPT.

Sub Generar_Presentacion()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim tableranges() As Excel.Range

Dim pptPath, pptName, lastpptPath As String
Dim FSO As Scripting.FileSystemObject
Dim check As Boolean
Dim i As Integer

Set FSO = New FileSystemObject
On Error Resume Next
pptName = "Plantilla"
pptPath = ThisWorkbook.Path & "\" & pptName & ".pptx"
lastpptPath = FSO.GetParentFolderName(pptPath)

On Error Resume Next
Set pptApp = GetObject("", "PowerPoint.Application")
Err.Clear
If pptApp Is Nothing Then Set pptApp = CreateObject(class:="PowerPoint.Appliaction")
pptApp.Visible = True
pptApp.Activate

On Error GoTo OpenPresentation
Set pptPres = pptApp.Presentations(pptName)
GoTo ContinueHere
OpenPresentation:
Set pptPres = pptApp.Presentations.Open(pptPath)
ContinueHere:

ReDim tableranges(1 To 10)

'Avance físico
Set tableranges(1) = ActiveWorkbook.Worksheets("Datos").Range("D1:G3")
'Avance Financiero
Set tableranges(2) = ActiveWorkbook.Worksheets("Datos").Range("I1:L4")
'Ejecución presupuestal
Set tableranges(3) = ActiveWorkbook.Worksheets("Datos").Range("D6:G9")
'Evaluación financiera
Set tableranges(4) = ActiveWorkbook.Worksheets("Datos").Range("D11:I14")
'Hitos (sin comentario)
Set tableranges(5) = ActiveWorkbook.Worksheets("Hitos2").Range("C1:F35")
'Alertas
Set tableranges(6) = ActiveWorkbook.Worksheets("Alertas").Range("A1:B27")
'Nombre proyecto
Set tableranges(7) = ActiveWorkbook.Worksheets("Datos").Range("B2:B2")
'Corte
Set tableranges(8) = ActiveWorkbook.Worksheets("Datos").Range("B3:B3")
Nombre_P = ActiveWorkbook.Worksheets("Datos").Range("B5")
corte = ActiveWorkbook.Worksheets("Datos").Range("B3")
Orden = ActiveWorkbook.Worksheets("Datos").Range("B1")
'Copia gráfica de CurvaS
Sheets("CurvaS").Select
ActiveSheet.ChartObjects(1).Select
ActiveSheet.ChartObjects(1).Copy
With pptPres.Slides(1).Shapes.PasteSpecial(ppPasteDefault)
.Name = ("CurvS")
.Top = 100
.Left = 50
End With
pptPres.Slides(1).Shapes("Nombre_P").TextFrame.TextRange.Text = Orden & ". " & Nombre_P
' Ajustar subtítulo con corte del mes
pptPres.Slides(1).Shapes("Corte").TextFrame.TextRange.Text = "Avance a " & Format(corte, "dd-mmmm-yyyy")

Sheets("Cumplimiento").Select
ActiveSheet.ChartObjects(1).Select
ActiveSheet.ChartObjects(1).Copy
With pptPres.Slides(1).Shapes.PasteSpecial(ppPasteDefault)
.Name = ("CurvPto")
.Top = 100
.Left = 400
End With
tableranges(1).Copy
With pptPres.Slides(1).Shapes.PasteSpecial(ppPasteDefault)
.Name = ("Tabla" & 1)
.Top = 300
.Left = 50
End With
tableranges(2).Copy
With pptPres.Slides(1).Shapes.PasteSpecial(ppPasteDefault)
.Name = ("Tabla" & 2)
.Top = 300
.Left = 400
End With
tableranges(3).Copy
With pptPres.Slides(1).Shapes.PasteSpecial(ppPasteDefault)
.Name = ("Tabla" & 3)
.Top = 380
.Left = 50
End With
tableranges(4).Copy
With pptPres.Slides(1).Shapes.PasteSpecial(ppPasteDefault)
.Name = ("Tabla" & 4)
.Top = 460
.Left = 50
End With
pptPres.Slides(2).Shapes("Nombre_P").TextFrame.TextRange.Text = Orden & ". " & Nombre_P
pptPres.Slides(2).Shapes("Corte").TextFrame.TextRange.Text = "Avance a " & Format(corte, "dd-mmmm-yyyy")
tableranges(5).Copy
With pptPres.Slides(2).Shapes.PasteSpecial(ppPasteDefault)
.Name = ("Tabla" & 5)
.Top = 120
.Left = 50
End With
pptPres.Slides(3).Shapes("Nombre_P").TextFrame.TextRange.Text = Orden & ". " & Nombre_P
pptPres.Slides(3).Shapes("Corte").TextFrame.TextRange.Text = "Avance a " & Format(corte, "dd-mmmm-yyyy")
tableranges(6).Copy
With pptPres.Slides(3).Shapes.PasteSpecial(ppPasteDefault)
.Name = ("Tabla" & 6)
.Top = 120
.Left = 50
End With
nom = ActiveWorkbook.Name
pto = InStr(nom, ".")
nomarch = Left(nom, pto - 1)
ruta = ThisWorkbook.Path
pptPres.SaveAs (ruta & "\" & nomarch)
'Cerrar el archivo
Sheets("Datos").Select
MsgBox ("La presentación se generó con éxito"), vbInformation, "AVISO"
End Sub